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

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

@ -42,210 +42,334 @@
[else (cons (car content) [else (cons (car content)
(strip-aux (cdr 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 ;; 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) (define/public (collect ds fns)
(let ([ht (make-hash-table 'equal)]) (let ([ci (make-collect-info (make-hash-table 'equal)
(map (lambda (d) (make-hash-table 'equal)
(collect-part d #f ht null)) (make-hash-table)
ds) (make-hash-table)
ht)) "")])
(start-collect ds fns ci)
ci))
(define/public (collect-part d parent ht number) (define/public (start-collect ds fns ci)
(let ([p-ht (make-hash-table 'equal)]) (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) (when (part-title-content d)
(collect-content (part-title-content d) p-ht)) (collect-content (part-title-content d) p-ci))
(collect-part-tags d p-ht number) (collect-part-tags d p-ci number)
(collect-content (part-to-collect d) p-ht) (collect-content (part-to-collect d) p-ci)
(collect-flow (part-flow d) p-ht) (collect-flow (part-flow d) p-ci)
(let loop ([parts (part-parts d)] (let loop ([parts (part-parts d)]
[pos 1]) [pos 1])
(unless (null? parts) (unless (null? parts)
(let ([s (car parts)]) (let ([s (car parts)])
(collect-part s d p-ht (collect-part s d p-ci
(cons (if (unnumbered-part? s) (cons (if (unnumbered-part? s)
#f #f
pos) pos)
number)) number))
(loop (cdr parts) (loop (cdr parts)
(if (unnumbered-part? s) pos (add1 pos)))))) (if (unnumbered-part? s) pos (add1 pos))))))
(set-part-collected-info! d (make-collected-info (hash-table-put! (collect-info-parts ci)
d
(make-collected-info
number number
parent parent
p-ht)) (collect-info-ht p-ci)))
(hash-table-for-each p-ht (let ([prefix (part-tag-prefix d)])
(hash-table-for-each (collect-info-ht p-ci)
(lambda (k v) (lambda (k v)
(hash-table-put! ht 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) (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))) (part-tags d)))
(define/public (collect-content c ht) (define/public (collect-content c ci)
(for-each (lambda (i) (for-each (lambda (i)
(collect-element i ht)) (collect-element i ci))
c)) c))
(define/public (collect-paragraph p ht) (define/public (collect-paragraph p ci)
(collect-content (paragraph-content p) ht)) (collect-content (paragraph-content p) ci))
(define/public (collect-flow p ht) (define/public (collect-flow p ci)
(for-each (lambda (p) (for-each (lambda (p)
(collect-flow-element p ht)) (collect-flow-element p ci))
(flow-paragraphs p))) (flow-paragraphs p)))
(define/public (collect-flow-element p ht) (define/public (collect-flow-element p ci)
(cond (cond
[(table? p) (collect-table p ht)] [(table? p) (collect-table p ci)]
[(itemization? p) (collect-itemization p ht)] [(itemization? p) (collect-itemization p ci)]
[(blockquote? p) (collect-blockquote p ht)] [(blockquote? p) (collect-blockquote p ci)]
[(delayed-flow-element? p) (void)] [(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) (for-each (lambda (d) (when (flow? d)
(collect-flow d ht))) (collect-flow d ci)))
(apply append (table-flowss i)))) (apply append (table-flowss i))))
(define/public (collect-itemization i ht) (define/public (collect-itemization i ci)
(for-each (lambda (d) (collect-flow d ht)) (for-each (lambda (d) (collect-flow d ci))
(itemization-flows i))) (itemization-flows i)))
(define/public (collect-blockquote i ht) (define/public (collect-blockquote i ci)
(for-each (lambda (d) (collect-flow-element d ht)) (for-each (lambda (d) (collect-flow-element d ci))
(blockquote-paragraphs i))) (blockquote-paragraphs i)))
(define/public (collect-element i ht) (define/public (collect-element i ci)
(when (target-element? i) (when (target-element? i)
(collect-target-element i ht)) (collect-target-element i ci))
(when (index-element? i) (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) (when (element? i)
(for-each (lambda (e) (for-each (lambda (e)
(collect-element e ht)) (collect-element e ci))
(element-content i)))) (element-content i))))
(define/public (collect-target-element i ht) (define/public (collect-target-element i ci)
(hash-table-put! ht (target-element-tag i) (list i))) (collect-put! ci
(generate-tag (target-element-tag i) ci)
(list i)))
(define/public (collect-index-element i ht) (define/public (collect-index-element i ci)
(hash-table-put! ht `(index-entry ,(index-element-tag i)) (collect-put! ci
`(index-entry ,(generate-tag (index-element-tag i) ci))
(list (index-element-plain-seq i) (list (index-element-plain-seq i)
(index-element-entry-seq i)))) (index-element-entry-seq i))))
(define/public (lookup part ht key) ;; ----------------------------------------
(let ([v (hash-table-get (if part ;; global-info resolution
(collected-info-info (part-collected-info part))
ht) (define/public (resolve ds fns ci)
key (let ([ri (make-resolve-info ci
#f)]) (make-hash-table)
(or v (make-hash-table 'equal))])
(and part (start-resolve ds fns ri)
(lookup (collected-info-parent ri))
(part-collected-info part))
ht (define/public (start-resolve ds fns ri)
key))))) (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 ;; render methods
(define/public (render ds fns ht) (define/public (render ds fns ri)
(map (lambda (d fn) (map (lambda (d fn)
(printf " [Output to ~a]\n" fn) (printf " [Output to ~a]\n" fn)
(with-output-to-file fn (with-output-to-file fn
(lambda () (lambda ()
(render-one d ht fn)) (render-one d ri fn))
'truncate/replace)) 'truncate/replace))
ds ds
fns)) fns))
(define/public (render-one d ht fn) (define/public (render-one d ri fn)
(render-part d ht)) (render-part d ri))
(define/public (render-part d ht) (define/public (render-part d ri)
(list (list
(when (part-title-content d) (when (part-title-content d)
(render-content (part-title-content d) d ht)) (render-content (part-title-content d) d ri))
(render-flow (part-flow d) d ht) (render-flow (part-flow d) d ri)
(map (lambda (s) (render-part s ht)) (map (lambda (s) (render-part s ri))
(part-parts d)))) (part-parts d))))
(define/public (render-content c part ht) (define/public (render-content c part ri)
(apply append (apply append
(map (lambda (i) (map (lambda (i)
(render-element i part ht)) (render-element i part ri))
c))) c)))
(define/public (render-paragraph p part ht) (define/public (render-paragraph p part ri)
(render-content (paragraph-content p) part ht)) (render-content (paragraph-content p) part ri))
(define/public (render-flow p part ht) (define/public (render-flow p part ri)
(apply append (apply append
(map (lambda (p) (map (lambda (p)
(render-flow-element p part ht)) (render-flow-element p part ri))
(flow-paragraphs p)))) (flow-paragraphs p))))
(define/public (render-flow-element p part ht) (define/public (render-flow-element p part ri)
(cond (cond
[(table? p) (if (auxiliary-table? p) [(table? p) (if (auxiliary-table? p)
(render-auxiliary-table p part ht) (render-auxiliary-table p part ri)
(render-table p part ht))] (render-table p part ri))]
[(itemization? p) (render-itemization p part ht)] [(itemization? p) (render-itemization p part ri)]
[(blockquote? p) (render-blockquote p part ht)] [(blockquote? p) (render-blockquote p part ri)]
[(delayed-flow-element? p) (render-flow-element [(delayed-flow-element? p)
((delayed-flow-element-render p) this part ht) (render-flow-element (delayed-flow-element-flow-elements p ri) part ri)]
part ht)] [else (render-paragraph p part ri)]))
[else (render-paragraph p part ht)]))
(define/public (render-auxiliary-table i part ht) (define/public (render-auxiliary-table i part ri)
null) null)
(define/public (render-table i part ht) (define/public (render-table i part ri)
(map (lambda (d) (if (flow? i) (map (lambda (d) (if (flow? i)
(render-flow d part ht) (render-flow d part ri)
null)) null))
(apply append (table-flowss i)))) (apply append (table-flowss i))))
(define/public (render-itemization i part ht) (define/public (render-itemization i part ri)
(map (lambda (d) (render-flow d part ht)) (map (lambda (d) (render-flow d part ri))
(itemization-flows i))) (itemization-flows i)))
(define/public (render-blockquote i part ht) (define/public (render-blockquote i part ri)
(map (lambda (d) (render-flow-element d part ht)) (map (lambda (d) (render-flow-element d part ri))
(blockquote-paragraphs i))) (blockquote-paragraphs i)))
(define/public (render-element i part ht) (define/public (render-element i part ri)
(cond (cond
[(and (link-element? i) [(and (link-element? i)
(null? (element-content 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 (if v
(render-content (strip-aux (car v)) part ht) (render-content (strip-aux (car v)) part ri)
(render-content (list "[missing]") part ht)))] (render-content (list "[missing]") part ri)))]
[(element? i) [(element? i)
(render-content (element-content i) part ht)] (render-content (element-content i) part ri)]
[(delayed-element? i) [(delayed-element? i)
(render-content (force-delayed-element i this part ht) part ht)] (render-content (delayed-element-content i ri) part ri)]
[else [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)) (list i))
;; ---------------------------------------- ;; ----------------------------------------
@ -280,34 +404,32 @@
;; ---------------------------------------- ;; ----------------------------------------
(define/private (do-table-of-contents part ht delta quiet) (define/private (do-table-of-contents part ri delta quiet)
(make-table #f (render-toc part (make-table #f (generate-toc part
ri
(+ delta (+ delta
(length (collected-info-number (length (collected-info-number
(part-collected-info part)))) (part-collected-info part ri))))
#t #t
quiet))) quiet)))
(define/public (table-of-contents part ht) (define/public (table-of-contents part ri)
(do-table-of-contents part ht -1 not)) (do-table-of-contents part ri -1 not))
(define/public (local-table-of-contents part ht) (define/public (local-table-of-contents part ri)
(table-of-contents part ht)) (table-of-contents part ri))
(define/public (quiet-table-of-contents part ht) (define/public (quiet-table-of-contents part ri)
(do-table-of-contents part ht 1 (lambda (x) #t))) (do-table-of-contents part ri 1 (lambda (x) #t)))
(define/private (render-toc part base-len skip? quiet) (define/private (generate-toc part ri base-len skip? quiet)
(let ([number (collected-info-number (part-collected-info part))]) (let ([number (collected-info-number (part-collected-info part ri))])
(let ([subs (let ([subs
(if (quiet (and (styled-part? part) (if (quiet (and (part-style? part 'quiet)
(let ([st(styled-part-style part)])
(or (eq? 'quiet st)
(and (list? st) (memq 'quiet st))))
(not (= base-len (sub1 (length number)))))) (not (= base-len (sub1 (length number))))))
(apply (apply
append 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)]) null)])
(if skip? (if skip?
subs subs
@ -324,8 +446,8 @@
(format-number number (format-number number
(list (list
(make-element 'hspace '(" ")))) (make-element 'hspace '(" "))))
(part-title-content part)) (or (part-title-content part) '("???")))
`(part ,(car (part-tags part))))))))) (car (part-tags part))))))))
subs)]) subs)])
(if (and (= 1 (length number)) (if (and (= 1 (length number))
(or (not (car number)) (or (not (car number))

83
collects/scribble/basic.ss
View File

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

116
collects/scribble/decode.ss
View File

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

4
collects/scribble/doclang.ss
View File

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

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

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

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

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

211
collects/scribble/manual.ss
View File

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

13
collects/scribble/run.ss
View File

@ -82,8 +82,15 @@
[files (reverse (current-info-input-files))]) [files (reverse (current-info-input-files))])
(if (null? files) (if (null? files)
info 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))))]) (cdr files))))])
(send renderer render docs fns info)) (let ([r-info (send renderer resolve docs fns info)])
(send renderer render docs fns r-info)
(when (current-info-output-file) (when (current-info-output-file)
(send renderer save-info (current-info-output-file) info))))))) (let ([s (send renderer serialize-info r-info)])
(with-output-to-file (current-info-output-file)
(lambda ()
(write s))
'truncate/replace))))))))))

221
collects/scribble/scheme.ss
View File

@ -1,9 +1,10 @@
(module scheme mzscheme (module scheme (lib "lang.ss" "big")
(require "struct.ss" (require "struct.ss"
"basic.ss" "basic.ss"
(lib "class.ss") (lib "class.ss")
(lib "for.ss") (lib "for.ss")
(lib "modcollapse.ss" "syntax")) (lib "main-collects.ss" "setup")
(lib "modresolve.ss" "syntax"))
(provide define-code (provide define-code
to-element to-element
@ -33,13 +34,7 @@
(define opt-color "schemeopt") (define opt-color "schemeopt")
(define current-keyword-list (define current-keyword-list
;; This is temporary, until the MzScheme manual is filled in... (make-parameter null))
(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)))
(define current-variable-list (define current-variable-list
(make-parameter null)) (make-parameter null))
(define current-meta-list (define current-meta-list
@ -51,7 +46,76 @@
(define-struct spaces (pre cnt post)) (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)] (let* ([c (syntax-ize c 0)]
[content null] [content null]
[docs null] [docs null]
@ -80,6 +144,10 @@
[(and (element? v) [(and (element? v)
(= 1 (length (element-content v)))) (= 1 (length (element-content v))))
(sz-loop (car (element-content v)))] (sz-loop (car (element-content v)))]
[(element? v)
(element-width v)]
[(delayed-element? v)
(element-width v)]
[(spaces? v) [(spaces? v)
(+ (sz-loop (spaces-pre v)) (+ (sz-loop (spaces-pre v))
(spaces-cnt v) (spaces-cnt v)
@ -176,13 +244,6 @@
c) c)
(loop (cdr l) (loop (cdr l)
(cons (car l) prev))))])))))) (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) (define (no-fancy-chars s)
(cond (cond
[(eq? s 'rsquo) "'"] [(eq? s 'rsquo) "'"]
@ -359,65 +420,10 @@
(set! src-col (+ orig-col (syntax-span c)))))] (set! src-col (+ orig-col (syntax-span c)))))]
[else [else
(advance c init-line!) (advance c init-line!)
(let-values ([(s it? sub?) (typeset-atom c out color? quote-depth)
(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))) (set! src-col (+ src-col (or (syntax-span c) 1)))
#; #;
(hash-table-put! next-col-map src-col dest-col))]))) (hash-table-put! next-col-map src-col dest-col)])))
(out prefix1 #f) (out prefix1 #f)
(set! dest-col 0) (set! dest-col 0)
(hash-table-put! next-col-map init-col dest-col) (hash-table-put! next-col-map init-col dest-col)
@ -436,6 +442,25 @@
(make-table "schemeblock" (map list (reverse docs)))) (make-table "schemeblock" (map list (reverse docs))))
(make-sized-element #f (reverse content) dest-col)))) (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) (define (to-element c)
(typeset c #f "" "" "" #t)) (typeset c #f "" "" "" #t))
@ -457,11 +482,11 @@
(cond (cond
[(syntax? v) [(syntax? v)
(let ([mk `(,#'d->s (let ([mk `(,#'d->s
(quote-syntax ,v) (quote-syntax ,(datum->syntax-object v 'defcode))
,(syntax-case v (uncode) ,(syntax-case v (uncode)
[(uncode e) #'e] [(uncode e) #'e]
[else (stx->loc-s-expr (syntax-e v))]) [else (stx->loc-s-expr (syntax-e v))])
(list 'code '(code
,(syntax-line v) ,(syntax-line v)
,(syntax-column v) ,(syntax-column v)
,(syntax-position v) ,(syntax-position v)
@ -484,27 +509,43 @@
[(_ expr) #`(typeset-code #,(cvt #'expr))] [(_ expr) #`(typeset-code #,(cvt #'expr))]
[(_ expr (... ...)) [(_ expr (... ...))
#`(typeset-code #,(cvt #'(code:line 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) [(_ code typeset-code uncode)
#'(define-code code typeset-code uncode datum->syntax-object syntax-property)] #'(define-code code typeset-code uncode datum->syntax-object syntax-property)]
[(_ code typeset-code) #'(define-code code typeset-code unsyntax)])) [(_ 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) (unless (identifier? stx)
(error 'register-scheme-definition "not an identifier: ~e" (syntax-object->datum stx))) (error 'register-scheme-definition "not an identifier: ~e" (syntax-object->datum stx)))
(format "definition:~a" (let ([b (identifier-label-binding stx)])
(let ([b (identifier-binding stx)]) (if (or (not b)
(cond (eq? b 'lexical))
[(not b) (format "top:~a" (syntax-e stx))] (if warn-if-no-label?
[(eq? b 'lexical) (format "lexical:~a" (syntax-e stx))] (begin
[else (format "module:~a:~a" (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)) (if (module-path-index? (car b))
(collapse-module-path-index (car b) '(lib "ack.ss" "scribble")) (let ([p (resolve-module-path-index (car b) #f)])
(path->main-collects-relative p))
(car b)) (car b))
(cadr b))])))) (cadr b)))))
(define (register-scheme-form-definition stx) (define (register-scheme-definition stx [warn-if-no-label? #f])
(format "form~s" (register-scheme-definition stx))) `(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))) (define syntax-ize-hook (make-parameter (lambda (v col) #f)))
@ -551,7 +592,11 @@
(just-context-ctx v)))] (just-context-ctx v)))]
[(and (list? v) [(and (list? v)
(pair? 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))]) (let ([c (syntax-ize (cadr v) (+ col 1))])
(datum->syntax-object #f (datum->syntax-object #f
(list (syntax-ize (car v) col) (list (syntax-ize (car v) col)

4
collects/scribble/scribble.css
View File

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

226
collects/scribble/struct.ss
View File

@ -1,8 +1,56 @@
(module struct mzscheme (module struct (lib "lang.ss" "big")
(require (lib "contract.ss") (require (lib "contract.ss")
(lib "serialize.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) (provide provide-structs)
(define-syntax (provide-structs stx) (define-syntax (provide-structs stx)
@ -36,12 +84,12 @@
fields+cts)))))])) fields+cts)))))]))
(provide tag?) (provide tag?)
(define (tag? s) (or (string? s) (define (tag? s) (and (pair? s)
(and (pair? s)
(symbol? (car s)) (symbol? (car s))
(pair? (cdr s)) (pair? (cdr s))
(string? (cadr s)) (or (string? (cadr s))
(null? (cddr s))))) (generated-tag? (cadr s)))
(null? (cddr s))))
(provide flow-element?) (provide flow-element?)
(define (flow-element? p) (define (flow-element? p)
@ -52,21 +100,21 @@
(delayed-flow-element? p))) (delayed-flow-element? p)))
(provide-structs (provide-structs
[part ([tags (listof tag?)] [part ([tag-prefix (or/c false/c string?)]
[tags (listof tag?)]
[title-content (or/c false/c list?)] [title-content (or/c false/c list?)]
[collected-info (or/c false/c collected-info?)] [style any/c]
[to-collect list?] [to-collect list?]
[flow flow?] [flow flow?]
[parts (listof part?)])] [parts (listof part?)])]
[(styled-part part) ([style any/c])] [(unnumbered-part part) ()]
[(unnumbered-part styled-part) ()]
[flow ([paragraphs (listof flow-element?)])] [flow ([paragraphs (listof flow-element?)])]
[paragraph ([content list?])] [paragraph ([content list?])]
[(styled-paragraph paragraph) ([style any/c])] [(styled-paragraph paragraph) ([style any/c])]
[table ([style any/c] [table ([style any/c]
[flowss (listof (listof (or/c flow? (one-of/c 'cont))))])] [flowss (listof (listof (or/c flow? (one-of/c 'cont))))])]
[(auxiliary-table table) ()] [(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?)])] [itemization ([flows (listof flow?)])]
[blockquote ([style any/c] [blockquote ([style any/c]
[paragraphs (listof flow-element?)])] [paragraphs (listof flow-element?)])]
@ -81,6 +129,7 @@
[plain-seq (listof string?)] [plain-seq (listof string?)]
[entry-seq list?])] [entry-seq list?])]
[(aux-element element) ()] [(aux-element element) ()]
[(hover-element element) ([text string?])]
;; specific renders support other elements, especially strings ;; specific renders support other elements, especially strings
[collected-info ([number (listof (or/c false/c integer?))] [collected-info ([number (listof (or/c false/c integer?))]
@ -93,42 +142,28 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Delayed element has special serialization support: ;; Delayed element has special serialization support:
(define-values (struct:delayed-element (define-struct delayed-element (resolve sizer plain)
make-delayed-element #:property
delayed-element? prop:serializable
delayed-element-ref
delayed-element-set!)
(make-struct-type 'delayed-element #f
3 1 #f
(list (cons prop:serializable
(make-serialize-info (make-serialize-info
(lambda (d) (lambda (d)
(unless (delayed-element-ref d 3) (let ([ri (current-serialize-resolve-info)])
(unless ri
(error 'serialize-delayed-element (error 'serialize-delayed-element
"cannot serialize a delayed element that was not resolved: ~e" "current-serialize-resolve-info not set"))
d)) (with-handlers ([exn:fail:contract?
(vector (delayed-element-ref d 3))) (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 #'deserialize-delayed-element
#f #f
(or (current-load-relative-directory) (current-directory))))))) (or (current-load-relative-directory) (current-directory))))
(define-syntax delayed-element (list-immutable #'struct:delayed-element
#'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))
(provide/contract (provide/contract
(struct delayed-element ([render (any/c part? any/c . -> . list?)] (struct delayed-element ([resolve (any/c part? resolve-info? . -> . list?)]
[sizer (-> any)] [sizer (-> any)]
[plain (-> any)]))) [plain (-> any)])))
@ -136,12 +171,90 @@
(define deserialize-delayed-element (define deserialize-delayed-element
(make-deserialize-info values values)) (make-deserialize-info values values))
(provide force-delayed-element) (provide delayed-element-content)
(define (force-delayed-element d renderer sec ht) (define (delayed-element-content e ri)
(or (delayed-element-ref d 3) (hash-table-get (resolve-info-delays ri) e))
(let ([v ((delayed-element-ref d 0) renderer sec ht)])
(delayed-element-set! d 3 v) (provide delayed-flow-element-flow-elements)
v))) (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 (define content->string
(case-lambda (case-lambda
[(c) (c->s c element->string)] [(c) (c->s c element->string)]
[(c renderer sec ht) (c->s c (lambda (e) [(c renderer sec ri) (c->s c (lambda (e)
(element->string e renderer sec ht)))])) (element->string e renderer sec ri)))]))
(define (c->s c do-elem) (define (c->s c do-elem)
(apply string-append (apply string-append
@ -171,12 +284,12 @@
[(rsquo) "'"] [(rsquo) "'"]
[(rarr) "->"] [(rarr) "->"]
[else (format "~s" c)])])] [else (format "~s" c)])])]
[(c renderer sec ht) [(c renderer sec ri)
(cond (cond
[(element? c) (content->string (element-content c) renderer sec ht)] [(element? c) (content->string (element-content c) renderer sec ri)]
[(delayed-element? c) [(delayed-element? c)
(content->string (force-delayed-element c renderer sec ht) (content->string (delayed-element-content c ri)
renderer sec ht)] renderer sec ri)]
[else (element->string c)])])) [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]. @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] @defform[(include-section module-path)]{ Requires @scheme[module-path]
and returns its @scheme[doc] export (without making any imports and returns its @scheme[doc] export (without making any imports
visible to the enclosing context). Since this form expands to 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} @title[#:tag "decode"]{Text Decoder}
The @file{decode.ss} library helps you write document content in a 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 Roughly, it processes a stream of strings to produces instances of the
@file{struct.ss} datatypes (see @secref["struct"]). @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 Decodes a document, producing a part. In @scheme[lst], instances of
@scheme[splice] are inlined into the list. An instance of @scheme[splice] are inlined into the list. An instance of
@scheme[title-decl] supplies the title for the part. Instances of @scheme[title-decl] supplies the title for the part. Instances of
@scheme[index-section-decl] (that preceed any sub-part) add index @scheme[part-index-decl] (that precede any sub-part) add index entries
entries that point to the section. Instances of @scheme[part-start] at that point to the section. Instances of @scheme[part-collect-decl] add
level 0 trigger sub-part parsing. Instances of @scheme[section] elements to the part that are used only during the @techlink{collect
trigger are used as-is as subsections, and instances of pass}. Instances of @scheme[part-start] at level 0 trigger sub-part
@scheme[paragraph] and other flow-element datatypes are used as-is in parsing. Instances of @scheme[section] trigger are used as-is as
the enclosing flow. subsections, and instances of @scheme[paragraph] and other
flow-element datatypes are used as-is in the enclosing flow.
} }
@defproc[(decode-part [lst list?] @defproc[(decode-part [lst list?]
[tag string?] [tags (listof string?)]
[title (or/c false/c list?)] [title (or/c false/c list?)]
[depth excat-nonnegative-integer?]) [depth excat-nonnegative-integer?])
part?]{ part?]{
Like @scheme[decode], but given a tag for the section, a title (if Like @scheme[decode], but given a list of tag string for the part, a
@scheme[#f], then a @scheme[title-decl] instance is used if found), title (if @scheme[#f], then a @scheme[title-decl] instance is used if
and a depth for @scheme[part-start]s to trigger sub-part parsing. 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?])]{ [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?] @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?])]{ [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?)] @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]. 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?])]{ @defstruct[splice ([run list?])]{
See @scheme[decode], @scheme[decode-part], and @scheme[decode-flow]. 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 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: includes @scheme[unsyntax], you can simply hide the usual binding:
@SCHEMEBLOCK[ @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] Or use @scheme[SCHEMEBLOCK], whose escape form is @scheme[UNSYNTAX]
instead of @scheme[unsyntax]. See also @scheme[define-code] from instead of @scheme[unsyntax].
@file{scheme.ss}.
A few other escapes are recognized symbolically: 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 @defproc[(commandline [pre-content any/c] ...) paragraph?]{Produces
an inset command-line example (e.g., in typewriter font).} 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.} 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} @section{Interface}
The @file{reader.ss} module provides very little functionality for The @file{reader.ss} module provides functionality for advanced needs.
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 [in input-port? (current-input-port)]) any]{}
@defproc[(read-syntax [source-name any/c (object-name in)] @defproc[(read-syntax [source-name any/c (object-name in)]
[in input-port? (current-input-port)]) [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 experimentation. (Note: enables line and column tracking.) The given
keyword arguments are used with `make-at-readtable'. 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") #reader(lib "docreader.ss" "scribble")
@require[(lib "manual.ss" "scribble")] @require[(lib "manual.ss" "scribble")]
@require["utils.ss"] @require["utils.ss"]
@require-for-label[(lib "class.ss")]
@title[#:tag "renderer"]{Renderer} @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 the renderer. Documents built with higher layers, such as
@file{manual.ss}, generally do not call the render object's methods @file{manual.ss}, generally do not call the render object's methods
directly. 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[(lib "bnf.ss" "scribble")]
@require["utils.ss"] @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 The @file{scribble} collection provides libraries that can be used to
create documents from Scheme. create documents from Scheme.
@table-of-contents[] @table-of-contents[]
@; ------------------------------------------------------------------------
@include-section["how-to.scrbl"]
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@section{Scribble Layers} @section{Scribble Layers}
@ -26,23 +30,24 @@ The layers are:
with @"@"-forms for conveniently embedding a mixin of text and with @"@"-forms for conveniently embedding a mixin of text and
escapes. See @secref["reader"].} escapes. See @secref["reader"].}
@item{@file{struct.ss}: a set of document datatypes, which define the @item{@file{struct.ss}: a set of document datatypes and utilities
basic layout of a document. See @secref["struct"].} that define the basic layout and processing of a document. See
@secref["struct"].}
@item{@file{base-render.ss} with @file{html-render.ss}, @item{@file{base-render.ss} with @file{html-render.ss},
@file{latex-render.ss}, or @file{text-render.ss}: A base @file{latex-render.ss}, or @file{text-render.ss}: A base
renderer and mixins that generate documents in various formats 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"].} @secref["renderer"].}
@item{@file{decode.ss}: Processes a stream of text, section-start @item{@file{decode.ss}: Processes a stream of text, section-start
markers, etc. to produce instances of the @file{struct.ss} 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 @item{@file{doclang.ss}: to be used for the initial import of a
module; processes the module top level through module; processes the module top level through
@file{decode.ss}, and otherwise provides all of @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 @item{@file{docreader.ss}: a reader that is meant to tbe used to
process an entire file; it essentially combines process an entire file; it essentially combines
@ -88,4 +93,3 @@ information.
@include-section["basic.scrbl"] @include-section["basic.scrbl"]
@include-section["manual.scrbl"] @include-section["manual.scrbl"]
@include-section["eval.scrbl"] @include-section["eval.scrbl"]
@include-section["style.scrbl"]

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

@ -2,50 +2,66 @@
@require[(lib "manual.ss" "scribble")] @require[(lib "manual.ss" "scribble")]
@require["utils.ss"] @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{ @itemize{
@item{A @defterm{part} is an instance of @scheme[part]; it has a list @item{A @deftech{table} is an instance of @scheme[table]; it
of @defterm{tags} used as link targets, a title has a list of list of @techlink{flows} with a particular
@defterm{content}, a list of @defterm{elements} that supply style. In Latex output, each table cell is typeset as a
information during the ``collect'' phase but are not rendered, single line.}
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 @defterm{flow} is an instance of @scheme[flow]; it has a list @item{A @deftech{itemization} is an instance of @scheme[itemization];
of @defterm{flow element}s.} it has a list of @techlink{flows}.}
@item{A @defterm{flow element} is either a @defterm{table}, an @item{A @deftech{blockquote} is an instance of
@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
@scheme[blockquote]; it has list of flow elements that @scheme[blockquote]; it has list of flow elements that
are indented according to a specified style.} are indented according to a specified style.}
@item{A @defterm{paragraph} is an instance of @scheme[paragraph]; it @item{A @deftech{paragraph} is an instance of
has a list of @defterm{element}s. @scheme[paragraph]; it has a @deftech{content}, which is
a list of @techlink{elements}:
@itemize{ @itemize{
@item{An element can be a string, one of a few symbols, an instance of @item{An @deftech{element} can be a string, one of a few
@scheme[element] (possibly @scheme[link-element], symbols, an instance of @scheme[element] (possibly
@scheme[target-element], or @scheme[link-element], etc.), a @techlink{delayed
@scheme[index-element]), a @defterm{delayed
element}, or anything else allowed by the current element}, or anything else allowed by the current
renderer. renderer.
@ -66,26 +82,21 @@ A single document is represented as a @defterm{part}:
@scheme['ndash], @scheme['ldquo], @scheme['ndash], @scheme['ldquo],
@scheme['lsquo], @scheme['rsquo], @scheme['lsquo], @scheme['rsquo],
@scheme['rarr], or @scheme['prime]; it is @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 @item{An instance of @scheme[element] has a list of
@defterm{element}s plus a style. The style's @techlink{elements} plus a style. The style's
interpretation depends on the rendrer; it can interpretation depends on the rendrer, but it
be one of a few special symbols that are can be one of a few special symbols (such as
recognized by all renderers: @scheme['tt], @scheme['bold]) that are recognized by all
@scheme['italic], @scheme['bold], renderers.}
@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.}
@item{An instance of @scheme[link-element] has a @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 @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 @scheme[link-element]s. An instance of the
subtype @scheme[toc-target-element] is subtype @scheme[toc-target-element] is
treated like a kind of section label, to be treated like a kind of section label, to be
@ -93,16 +104,23 @@ A single document is represented as a @defterm{part}:
output.} output.}
@item{An instance of @scheme[index-element] has a @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 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.} 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 @scheme[delayed-element], which has a
procedure that produces a procedure that is called in the
@defterm{element}. The ``collect'' phase of @techlink{resolve pass} of document
rendering ignores delayed flow elements.} processing to obtain @defterm{content} (i.e.,
a list of @defterm{elements}).}
@item{An instance of @scheme[aux-element] is @item{An instance of @scheme[aux-element] is
excluded in the text of a link when it 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 @scheme[delayed-flow-element], which has a procedure that
produces a @defterm{flow element}. The ``collect'' phase is called in the @techlink{resolve pass} of document
of rendering ignores delayed flow elements.} processing to obtain a @defterm{flow element}.}
}}
@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.}
} }
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?)] [title-content (or/c false/c list?)]
[collected-info (or/c false/c collected-info?)] [style any/c]
[to-collect list?] [to-collect list?]
[flow flow?] [flow flow?]
[parts (listof part?)])]{ [parts (listof part?)])]{
Each element of @scheme[tags] is actually wrapped as @scheme[`(part The @scheme[tag-prefix] field determines the optional @techlink{tag
,_tag)] as a target for links; functions like @scheme[seclink] prefix} for the part.
similarly insert the @scheme[`(part ,_tag)] wrapper.
} 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 @scheme[style] field is normally either a symbol or a list of
symbols. The currently recognized style symbols (alone or in a list)
The currently recognized values for @scheme[style] are as follows: are as follows:
@itemize{ @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['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 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?)])]{ @defstruct[flow ([paragraphs (listof flow-element?)])]{
A @techlink{flow} has a list of flow elements.
} }
@defstruct[paragraph ([content list?])]{ @defstruct[paragraph ([content list?])]{
A @techlink{paragraph} has a list of elements.
} }
@defstruct[(styled-paragraph paragraph) ([style any/c])]{ @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] @defstruct[table ([style any/c]
[flowss (listof (listof flow?))])]{ [flowss (listof (listof (or/c flow? (one-of/c 'cont))))])]{
} 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
@defstruct[delayed-flow-element ([render (any/c part? any/c . -> . flow-element?)])]{ of cells that contain a single flow).
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).
} }
@defstruct[itemization ([flows (listof flow?)])]{ @defstruct[itemization ([flows (listof flow?)])]{
A @techlink{itemization} has a list of flows.
} }
@defstruct[blockquote ([style any/c] @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] @defstruct[element ([style any/c]
[content list?])]{ [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?])]{ @defstruct[(target-element element) ([tag tag?])]{
Declares the content as a hyperlink target for @scheme[tag].
} }
@defstruct[(toc-target-element target-element) ()]{ @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].
} }
@ -228,48 +365,68 @@ section, and the last argument correspond to global information
The @scheme[plain-seq] specifies the keys for sorting, where the first 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 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 @scheme[entry-seq] list must have the same length, and it provides
form of each key to render in the final document. See also the form of each key to render in the final document. See also
@scheme[index]. @scheme[index].
} }
@defstruct[(aux-element element) ()]{ @defstruct[(aux-element element) ()]{
Instances of this structure type are intended for use in titles, where 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 the auxiliary part of the title can be omitted in hyperlinks. See,
example, @scheme[secref]. 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)] [sizer (-> any/c)]
[plain (-> any/c)])]{ [plain (-> any/c)])]{
The @scheme[render] procedure's arguments are the same as for The @scheme[render] procedure's arguments are the same as for
@scheme[delayed-flow-element]. Unlike @scheme[delayed-flow-element], @scheme[delayed-flow-element]. Unlike @scheme[delayed-flow-element],
the result of the @scheme[render] procedure's argument is remembered the result of the @scheme[render] procedure's argument is remembered
on the first call. Furthemore, the element can be marshelled (e.g., on the first call.
for an index entry or a section-title entry) only if it has been
rendered first.
The @scheme[sizer] field is a procedure that produces a substitute The @scheme[sizer] field is a procedure that produces a substitute
element for the delayed element for the purposes of determine the element for the delayed element for the purposes of determining the
element's width (see @scheme[element-width]). element's width (see @scheme[element-width]).
The @scheme[plain] field is a procedure that produces a substitute for 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?))] @defstruct[collected-info ([number (listof (or/c false/c integer?))]
[parent (or/c false/c part?)] [parent (or/c false/c part?)]
[info any/c])]{ [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?]{ @defproc[(flow-element? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a @scheme[paragraph], 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?]{ @defproc[(tag? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is acceptable as a link tag, Returns @scheme[#t] if @scheme[v] is acceptable as a link tag, which
@scheme[#f], otherwise. Currently, an acceptable tag is either a is a list containing a symbol and either a string or a
string or a list containing a symbol and a string.} @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?] @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 Converts a list of elements to a single string (essentially
rendering the content as ``plain text''). 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?] @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. 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.
}

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

@ -2,9 +2,7 @@
@require[(lib "manual.ss" "scribble")] @require[(lib "manual.ss" "scribble")]
@require["utils.ss"] @require["utils.ss"]
@title[#:tag "reference-style"]{PLT Reference Style Guide} @title[#:tag "reference-style"]{Style Guide}
@italic{Notes toward an eventual guide chapter...}
In the descriptive body of @scheme[defform], @scheme[defproc], etc., 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
@ -20,24 +18,6 @@ expression position within a syntactic form. Use @schemeidfont{body}
for a form (definition or expression) in an internal-definition for a form (definition or expression) in an internal-definition
position. 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 Pay attention to the difference between identifiers and meta-variables
when using @scheme[scheme], especially outside of @scheme[defproc] or when using @scheme[scheme], especially outside of @scheme[defproc] or
@scheme[defform]. Prefix a meta-variable with @litchar{_}; for @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")) (prefix scribble: (lib "reader.ss" "scribble"))
(lib "string.ss")) (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) (provide scribble-examples litchar/lines)
(define (litchar/lines . strs) (define (litchar/lines . strs)