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

major Scribble revision (v4.2.1.2)

Browse Source 
svn: r15569
This commit is contained in:
Matthew Flatt 2009-07-25 20:25:33 +00:00
parent f0c42b1730
commit 345c17e85c
139 changed files with 8095 additions and 4053 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/deinprogramm/scribblings/DMdA-beginner.scrbl
View File

@ -200,7 +200,7 @@ sie bindet den Namen @scheme[id] an den Vertrag @scheme[contract].
Die zweite Form führt einen @deftech{parametrischen Vertrag} (wie Die zweite Form führt einen @deftech{parametrischen Vertrag} (wie
@scheme[list]) ein, der über die Parameter @scheme[p1] @scheme[list]) ein, der über die Parameter @scheme[p1]
... abstrahiert. Der parametrische Vertrag kann dann als @schemeidfont['(id ... abstrahiert. Der parametrische Vertrag kann dann als @scheme['(id
a1 ...)] verwendet werden, wobei in @scheme[contract] für die a1 ...)] verwendet werden, wobei in @scheme[contract] für die
Parameter @scheme[p1] ... die @scheme[a1] ... eingesetzt werden. Parameter @scheme[p1] ... die @scheme[a1] ... eingesetzt werden.
} }

12
collects/framework/main.ss
View File

@ -854,7 +854,7 @@
() ()
@{This returns the reset unlocked @scheme[bitmap]. @{This returns the reset unlocked @scheme[bitmap].
The bitmap may not respond @scheme[#t] to the @link bitmap ok? The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?]
method.}) method.})
(proc-doc/names (proc-doc/names
@ -870,10 +870,10 @@
icon:get-left/right-cursor icon:get-left/right-cursor
(-> (is-a?/c cursor%)) (-> (is-a?/c cursor%))
() ()
@{This function returns a @link cursor object that indicates @{This function returns a @scheme[cursor%] object that indicates
left/right sizing is possible, for use with columns inside a window. left/right sizing is possible, for use with columns inside a window.
The cursor may not respond @scheme[#t] to the @link cursor ok? The cursor may not respond @scheme[#t] to the @method[cursor% ok?]
method.}) method.})
(proc-doc/names (proc-doc/names
@ -893,7 +893,7 @@
@{This returns a bitmap to be displayed in an @scheme[frame:info<%>] @{This returns a bitmap to be displayed in an @scheme[frame:info<%>]
frame when garbage collection is taking place. frame when garbage collection is taking place.
The bitmap may not respond @scheme[#t] to the @link bitmap ok? The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?]
method.}) method.})
(proc-doc/names (proc-doc/names
@ -1233,7 +1233,7 @@
keymap:setup-search keymap:setup-search
((is-a?/c keymap%) . -> . void?) ((is-a?/c keymap%) . -> . void?)
(keymap) (keymap)
@{This extends a @link keymap with the bindings for searching.}) @{This extends a @scheme[keymap%] with the bindings for searching.})
(proc-doc/names (proc-doc/names
keymap:set-chained-keymaps keymap:set-chained-keymaps
@ -1344,7 +1344,7 @@
scheme:get-wordbreak-map scheme:get-wordbreak-map
(-> (is-a?/c editor-wordbreak-map%)) (-> (is-a?/c editor-wordbreak-map%))
() ()
@{This method returns a @link editor-wordbreak-map that is suitable @{This method returns a @scheme[editor-wordbreak-map%] that is suitable
for Scheme.}) for Scheme.})
(proc-doc/names (proc-doc/names

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

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require "struct.ss" (require "core.ss"
"private/render-utils.ss"
mzlib/class mzlib/class
mzlib/serialize mzlib/serialize
scheme/file scheme/file
@ -51,35 +52,108 @@
;; ---------------------------------------- ;; ----------------------------------------
(define/public (extract-part-style-files d ri tag stop-at-part?) (define/public (extract-part-style-files d ri tag stop-at-part? pred extract)
(let loop ([p d][up? #t][only-up? #f]) (let ([ht (make-hash)])
(let ([s (part-style p)]) (let loop ([p d][up? #t][only-up? #f])
(apply (let ([s (part-style p)])
append (when up?
(if up? (let ([p (collected-info-parent (part-collected-info p ri))])
(let ([p (collected-info-parent (part-collected-info p ri))]) (if p
(if p (loop p #t #t)
(loop p #t #t) null)))
null)) (extract-style-style-files (part-style p) ht pred extract)
null) (unless only-up?
(if (list? s) (extract-content-style-files (part-to-collect p) d ri ht pred extract)
(filter (extract-content-style-files (part-title-content p) d ri ht pred extract)
values (extract-flow-style-files (part-blocks p) d ri ht pred extract))
(map (lambda (s) (unless only-up?
(and (list? s) (for-each (lambda (p)
(= 2 (length s)) (unless (stop-at-part? p)
(eq? (car s) tag) (loop p #f #f)))
(path-string? (cadr s)) (part-parts p)))))
(cadr s))) (for/list ([k (in-hash-keys ht)]) (main-collects-relative->path k))))
s))
null) (define/private (extract-style-style-files s ht pred extract)
(if only-up? (for ([v (in-list (style-variants s))])
null (when (pred v)
(map (lambda (p) (hash-set! ht (extract v) #t))))
(if (stop-at-part? p)
null (define/private (extract-flow-style-files blocks d ri ht pred extract)
(loop p #f #f))) (for ([b (in-list blocks)])
(part-parts p))))))) (extract-block-style-files b d ri ht pred extract)))
(define/private (extract-block-style-files p d ri ht pred extract)
(cond
[(table? p)
(extract-style-style-files (table-style p) ht pred extract)
(for-each (lambda (blocks)
(for-each (lambda (block)
(unless (eq? block 'cont)
(extract-block-style-files block d ri ht pred extract)))
blocks))
(table-blockss p))]
[(itemization? p)
(extract-style-style-files (itemization-style p) ht pred extract)
(for-each (lambda (blocks)
(extract-flow-style-files blocks d ri ht pred extract))
(itemization-blockss p))]
[(nested-flow? p)
(extract-style-style-files (nested-flow-style p) ht pred extract)
(extract-flow-style-files (nested-flow-blocks p) d ri ht pred extract)]
[(compound-paragraph? p)
(extract-style-style-files (compound-paragraph-style p) ht pred extract)
(extract-flow-style-files (compound-paragraph-blocks p) d ri ht pred extract)]
[(delayed-block? p)
(let ([v ((delayed-block-resolve p) this d ri)])
(extract-block-style-files v d ri ht pred extract))]
[else
(extract-style-style-files (paragraph-style p) ht pred extract)
(extract-content-style-files (paragraph-content p) d ri ht pred extract)]))
(define/private (extract-content-style-files e d ri ht pred extract)
(cond
[(element? e)
(when (style? (element-style e))
(extract-style-style-files (element-style e) ht pred extract))
(extract-content-style-files (element-content e) d ri ht pred extract)]
[(multiarg-element? e)
(when (style? (multiarg-element-style e))
(extract-style-style-files (multiarg-element-style e) ht pred extract))
(extract-content-style-files (multiarg-element-contents e) d ri ht pred extract)]
[(list? e)
(for ([e (in-list e)])
(extract-content-style-files e d ri ht pred extract))]
[(delayed-element? e)
(extract-content-style-files (delayed-element-content e ri) d ri ht pred extract)]
[(part-relative-element? e)
(extract-content-style-files (part-relative-element-content e ri) d ri ht pred extract)]))
(define/public (extract-version d)
(or (ormap (lambda (v)
(and (document-version? v)
(document-version-text v)))
(style-variants (part-style d)))
""))
(define/private (extract-pre-paras d sym)
(let loop ([l (part-blocks d)])
(cond
[(null? l) null]
[else (let ([v (car l)])
(cond
[(and (paragraph? v)
(eq? sym (style-name (paragraph-style v))))
(cons v (loop (cdr l)))]
[(compound-paragraph? v)
(append (loop (compound-paragraph-blocks v))
(loop (cdr l)))]
[else (loop (cdr l))]))])))
(define/public (extract-authors d)
(extract-pre-paras d 'author))
(define/public (extract-pretitle d)
(extract-pre-paras d 'pretitle))
;; ---------------------------------------- ;; ----------------------------------------
@ -196,20 +270,18 @@
(collect-content (part-title-content d) p-ci)) (collect-content (part-title-content d) p-ci))
(collect-part-tags d p-ci number) (collect-part-tags d p-ci number)
(collect-content (part-to-collect d) p-ci) (collect-content (part-to-collect d) p-ci)
(collect-flow (part-flow d) p-ci) (collect-flow (part-blocks 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-ci (collect-part s d p-ci
(cons (if (or (unnumbered-part? s) (cons (if (part-style? s 'unnumbered)
(part-style? s 'unnumbered))
#f #f
pos) pos)
number)) number))
(loop (cdr parts) (loop (cdr parts)
(if (or (unnumbered-part? s) (if (part-style? s 'unnumbered)
(part-style? s 'unnumbered))
pos pos
(add1 pos))))))) (add1 pos)))))))
(let ([prefix (part-tag-prefix d)]) (let ([prefix (part-tag-prefix d)])
@ -241,41 +313,38 @@
number number
(add-current-tag-prefix t)))))) (add-current-tag-prefix t))))))
(define/public (collect-content c ci)
(for ([i (in-list c)]) (collect-element i ci)))
(define/public (collect-paragraph p ci) (define/public (collect-paragraph p ci)
(collect-content (paragraph-content p) ci)) (collect-content (paragraph-content p) ci))
(define/public (collect-flow p ci) (define/public (collect-flow p ci)
(for ([p (in-list (flow-paragraphs p))]) (for ([p (in-list p)])
(collect-block p ci))) (collect-block p ci)))
(define/public (collect-block p ci) (define/public (collect-block p ci)
(cond [(table? p) (collect-table p ci)] (cond [(table? p) (collect-table p ci)]
[(itemization? p) (collect-itemization p ci)] [(itemization? p) (collect-itemization p ci)]
[(blockquote? p) (collect-blockquote p ci)] [(nested-flow? p) (collect-nested-flow p ci)]
[(compound-paragraph? p) (collect-compound-paragraph p ci)] [(compound-paragraph? p) (collect-compound-paragraph p ci)]
[(delayed-block? p) (void)] [(delayed-block? p) (void)]
[else (collect-paragraph p ci)])) [else (collect-paragraph p ci)]))
(define/public (collect-table i ci) (define/public (collect-table i ci)
(for ([d (in-list (apply append (table-flowss i)))]) (for ([d (in-list (apply append (table-blockss i)))])
(when (flow? d) (collect-flow d ci)))) (unless (eq? d 'cont) (collect-block d ci))))
(define/public (collect-itemization i ci) (define/public (collect-itemization i ci)
(for ([d (in-list (itemization-flows i))]) (for ([d (in-list (itemization-blockss i))])
(collect-flow d ci))) (collect-flow d ci)))
(define/public (collect-blockquote i ci) (define/public (collect-nested-flow i ci)
(for ([d (in-list (blockquote-paragraphs i))]) (for ([d (in-list (nested-flow-blocks i))])
(collect-block d ci))) (collect-block d ci)))
(define/public (collect-compound-paragraph i ci) (define/public (collect-compound-paragraph i ci)
(for ([d (in-list (compound-paragraph-blocks i))]) (for ([d (in-list (compound-paragraph-blocks i))])
(collect-block d ci))) (collect-block d ci)))
(define/public (collect-element i ci) (define/public (collect-content i ci)
(if (part-relative-element? i) (if (part-relative-element? i)
(let ([content (or (hash-ref (collect-info-relatives ci) i #f) (let ([content (or (hash-ref (collect-info-relatives ci) i #f)
(let ([v ((part-relative-element-collect i) ci)]) (let ([v ((part-relative-element-collect i) ci)])
@ -286,7 +355,11 @@
(when (index-element? i) (collect-index-element i ci)) (when (index-element? i) (collect-index-element i ci))
(when (collect-element? i) ((collect-element-collect i) ci)) (when (collect-element? i) ((collect-element-collect i) ci))
(when (element? i) (when (element? i)
(for ([e (element-content i)]) (collect-element e ci)))))) (collect-content (element-content i) ci))
(when (multiarg-element? i)
(collect-content (multiarg-element-contents i) ci))
(when (list? i)
(for ([e (in-list i)]) (collect-content e ci))))))
(define/public (collect-target-element i ci) (define/public (collect-target-element i ci)
(let ([t (generate-tag (target-element-tag i) ci)]) (let ([t (generate-tag (target-element-tag i) ci)])
@ -315,26 +388,22 @@
(extend-prefix d (fresh-tag-resolve-context? d ri))]) (extend-prefix d (fresh-tag-resolve-context? d ri))])
(when (part-title-content d) (when (part-title-content d)
(resolve-content (part-title-content d) d ri)) (resolve-content (part-title-content d) d ri))
(resolve-flow (part-flow d) d ri) (resolve-flow (part-blocks d) d ri)
(for ([p (part-parts d)]) (for ([p (part-parts d)])
(resolve-part p ri)))) (resolve-part p ri))))
(define/public (resolve-content c d ri)
(for ([i (in-list c)])
(resolve-element i d ri)))
(define/public (resolve-paragraph p d ri) (define/public (resolve-paragraph p d ri)
(resolve-content (paragraph-content p) d ri)) (resolve-content (paragraph-content p) d ri))
(define/public (resolve-flow p d ri) (define/public (resolve-flow f d ri)
(for ([p (flow-paragraphs p)]) (for ([p (in-list f)])
(resolve-block p d ri))) (resolve-block p d ri)))
(define/public (resolve-block p d ri) (define/public (resolve-block p d ri)
(cond (cond
[(table? p) (resolve-table p d ri)] [(table? p) (resolve-table p d ri)]
[(itemization? p) (resolve-itemization p d ri)] [(itemization? p) (resolve-itemization p d ri)]
[(blockquote? p) (resolve-blockquote p d ri)] [(nested-flow? p) (resolve-nested-flow p d ri)]
[(compound-paragraph? p) (resolve-compound-paragraph p d ri)] [(compound-paragraph? p) (resolve-compound-paragraph p d ri)]
[(delayed-block? p) [(delayed-block? p)
(let ([v ((delayed-block-resolve p) this d ri)]) (let ([v ((delayed-block-resolve p) this d ri)])
@ -343,22 +412,22 @@
[else (resolve-paragraph p d ri)])) [else (resolve-paragraph p d ri)]))
(define/public (resolve-table i d ri) (define/public (resolve-table i d ri)
(for ([f (in-list (apply append (table-flowss i)))]) (for ([f (in-list (apply append (table-blockss i)))])
(when (flow? f) (resolve-flow f d ri)))) (unless (eq? f 'cont) (resolve-block f d ri))))
(define/public (resolve-itemization i d ri) (define/public (resolve-itemization i d ri)
(for ([f (in-list (itemization-flows i))]) (for ([f (in-list (itemization-blockss i))])
(resolve-flow f d ri))) (resolve-flow f d ri)))
(define/public (resolve-blockquote i d ri) (define/public (resolve-nested-flow i d ri)
(for ([f (in-list (blockquote-paragraphs i))]) (for ([f (in-list (nested-flow-blocks i))])
(resolve-block f d ri))) (resolve-block f d ri)))
(define/public (resolve-compound-paragraph i d ri) (define/public (resolve-compound-paragraph i d ri)
(for ([f (in-list (compound-paragraph-blocks i))]) (for ([f (in-list (compound-paragraph-blocks i))])
(resolve-block f d ri))) (resolve-block f d ri)))
(define/public (resolve-element i d ri) (define/public (resolve-content i d ri)
(cond (cond
[(part-relative-element? i) [(part-relative-element? i)
(resolve-content (part-relative-element-content i ri) d ri)] (resolve-content (part-relative-element-content i ri) d ri)]
@ -368,6 +437,9 @@
(hash-set! (resolve-info-delays ri) i v) (hash-set! (resolve-info-delays ri) i v)
v)) v))
d ri)] d ri)]
[(list? i)
(for ([i (in-list i)])
(resolve-content i d ri))]
[(element? i) [(element? i)
(cond (cond
[(index-element? i) [(index-element? i)
@ -377,19 +449,30 @@
(hash-set! (resolve-info-delays ri) e v))))] (hash-set! (resolve-info-delays ri) e v))))]
[(link-element? i) [(link-element? i)
(resolve-get d ri (link-element-tag i))]) (resolve-get d ri (link-element-tag i))])
(for ([e (element-content i)]) (resolve-content (element-content i) d ri)]
(resolve-element e d ri))])) [(multiarg-element? i)
(resolve-content (multiarg-element-contents i) d ri)]))
;; ---------------------------------------- ;; ----------------------------------------
;; render methods ;; render methods
(define/public (install-extra-files) (define/public (auto-extra-files? v) #f)
(for ([fn extra-files]) (install-file fn))) (define/public (auto-extra-files-paths v) null)
(define/public (install-extra-files ds)
(for ([fn extra-files]) (install-file fn))
(unless prefix-file
(for ([d (in-list ds)])
(let ([extras (ormap (lambda (v) (and (auto-extra-files? v) v))
(style-variants (part-style d)))])
(when extras
(for ([fn (in-list (auto-extra-files-paths extras))])
(install-file (main-collects-relative->path fn))))))))
(define/public (render ds fns ri) (define/public (render ds fns ri)
;; maybe this should happen even if fns is empty or all #f? ;; maybe this should happen even if fns is empty or all #f?
;; or maybe it should happen for each file rendered (when d is not #f)? ;; or maybe it should happen for each file rendered (when d is not #f)?
(unless (andmap not ds) (install-extra-files)) (unless (andmap not ds) (install-extra-files ds))
(map (lambda (d fn) (map (lambda (d fn)
(define (one) (render-one d ri fn)) (define (one) (render-one d ri fn))
(when (report-output?) (printf " [Output to ~a]\n" fn)) (when (report-output?) (printf " [Output to ~a]\n" fn))
@ -415,13 +498,10 @@
(list (list
(when (part-title-content d) (when (part-title-content d)
(render-content (part-title-content d) d ri)) (render-content (part-title-content d) d ri))
(render-flow (part-flow d) d ri #f) (render-flow (part-blocks d) d ri #f)
(map (lambda (s) (render-part s ri)) (map (lambda (s) (render-part s ri))
(part-parts d)))) (part-parts d))))
(define/public (render-content c part ri)
(apply append (map (lambda (i) (render-element i part ri)) c)))
(define/public (render-paragraph p part ri) (define/public (render-paragraph p part ri)
(render-content (paragraph-content p) part ri)) (render-content (paragraph-content p) part ri))
@ -436,49 +516,51 @@
(loop (cdr l) #f))])))) (loop (cdr l) #f))]))))
(define/public (render-flow p part ri starting-item?) (define/public (render-flow p part ri starting-item?)
(if (null? (flow-paragraphs p)) (if (null? p)
null null
(append (append
(render-block (car (flow-paragraphs p)) (render-block (car p)
part ri starting-item?) part ri starting-item?)
(apply append (apply append
(map (lambda (p) (map (lambda (p)
(render-block p part ri #f)) (render-block p part ri #f))
(cdr (flow-paragraphs p))))))) (cdr p))))))
(define/public (render-intrapara-block p part ri first? last? starting-item?) (define/public (render-intrapara-block p part ri first? last? starting-item?)
(render-block p part ri starting-item?)) (render-block p part ri starting-item?))
(define/public (render-block p part ri inline?) (define/public (render-block p part ri starting-item?)
(cond (cond
[(table? p) (if (auxiliary-table? p) [(table? p) (if (memq 'aux (style-variants (table-style p)))
(render-auxiliary-table p part ri) (render-auxiliary-table p part ri)
(render-table p part ri inline?))] (render-table p part ri starting-item?))]
[(itemization? p) (render-itemization p part ri)] [(itemization? p) (render-itemization p part ri)]
[(blockquote? p) (render-blockquote p part ri)] [(nested-flow? p) (render-nested-flow p part ri)]
[(compound-paragraph? p) (render-compound-paragraph p part ri inline?)] [(compound-paragraph? p) (render-compound-paragraph p part ri starting-item?)]
[(delayed-block? p) [(delayed-block? p)
(render-block (delayed-block-blocks p ri) part ri inline?)] (render-block (delayed-block-blocks p ri) part ri starting-item?)]
[else (render-paragraph p part ri)])) [else (render-paragraph p part ri)]))
(define/public (render-auxiliary-table i part ri) (define/public (render-auxiliary-table i part ri)
null) null)
(define/public (render-table i part ri inline?) (define/public (render-table i part ri starting-item?)
(map (lambda (d) (if (flow? i) (render-flow d part ri #f) null)) (map (lambda (d) (if (eq? i 'cont) null (render-block d part ri #f)))
(apply append (table-flowss i)))) (apply append (table-blockss i))))
(define/public (render-itemization i part ri) (define/public (render-itemization i part ri)
(map (lambda (d) (render-flow d part ri #t)) (map (lambda (d) (render-flow d part ri #t))
(itemization-flows i))) (itemization-blockss i)))
(define/public (render-blockquote i part ri) (define/public (render-nested-flow i part ri)
(map (lambda (d) (render-block d part ri #f)) (map (lambda (d) (render-block d part ri #f))
(blockquote-paragraphs i))) (nested-flow-blocks i)))
(define/public (render-element i part ri) (define/public (render-content i part ri)
(cond (cond
[(string? i) (render-other i part ri)] ; short-cut for common case [(string? i) (render-other i part ri)] ; short-cut for common case
[(list? i)
(apply append (for/list ([i (in-list i)]) (render-content i part ri)))]
[(and (link-element? i) [(and (link-element? i)
(null? (element-content i))) (null? (element-content i)))
(let ([v (resolve-get part ri (link-element-tag i))]) (let ([v (resolve-get part ri (link-element-tag i))])
@ -489,6 +571,8 @@
(when (render-element? i) (when (render-element? i)
((render-element-render i) this part ri)) ((render-element-render i) this part ri))
(render-content (element-content i) part ri)] (render-content (element-content i) part ri)]
[(multiarg-element? i)
(render-content (multiarg-element-contents i) part ri)]
[(delayed-element? i) [(delayed-element? i)
(render-content (delayed-element-content i ri) part ri)] (render-content (delayed-element-content i ri) part ri)]
[(part-relative-element? i) [(part-relative-element? i)
@ -568,15 +652,15 @@
;; ---------------------------------------- ;; ----------------------------------------
(define/private (do-table-of-contents part ri delta quiet depth) (define/private (do-table-of-contents part ri delta quiet depth)
(make-table #f (generate-toc part (make-table plain (generate-toc part
ri ri
(+ delta (+ delta
(length (collected-info-number (length (collected-info-number
(part-collected-info part ri)))) (part-collected-info part ri))))
#t #t
quiet quiet
depth depth
null))) null)))
(define/public (table-of-contents part ri) (define/public (table-of-contents part ri)
(do-table-of-contents part ri -1 not +inf.0)) (do-table-of-contents part ri -1 not +inf.0))
@ -605,31 +689,30 @@
(if skip? (if skip?
subs subs
(let ([l (cons (let ([l (cons
(list (make-flow (list (make-paragraph
plain
(list (list
(make-paragraph (make-element
(list 'hspace
(make-element (list (make-string (* 2 (- (length number)
'hspace base-len))
(list (make-string (* 2 (- (length number) #\space)))
base-len)) (make-link-element
#\space))) (if (= 1 (length number)) "toptoclink" "toclink")
(make-link-element (append
(if (= 1 (length number)) "toptoclink" "toclink") (format-number
(append number
(format-number (list (make-element 'hspace '(" "))))
number (or (part-title-content part) '("???")))
(list (make-element 'hspace '(" ")))) (for/fold ([t (car (part-tags part))])
(or (part-title-content part) '("???"))) ([prefix (in-list prefixes)])
(for/fold ([t (car (part-tags part))]) (convert-key prefix t))))))
([prefix (in-list prefixes)])
(convert-key prefix t))))))))
subs)]) subs)])
(if (and (= 1 (length number)) (if (and (= 1 (length number))
(or (not (car number)) ((car number) . > . 1))) (or (not (car number)) ((car number) . > . 1)))
(cons (list (make-flow (cons (list (make-paragraph
(list (make-paragraph plain
(list (make-element 'hspace (list ""))))))) (list (make-element 'hspace (list "")))))
l) l)
l))))) l)))))

740
collects/scribble/base.ss Normal file
View File

@ -0,0 +1,740 @@
#lang scheme/base
(require "decode.ss"
"core.ss"
"manual-struct.ss"
"decode-struct.ss"
"html-variants.ss"
scheme/list
scheme/class
scheme/contract
setup/main-collects
syntax/modresolve
(for-syntax scheme/base))
;; ----------------------------------------
(define-syntax-rule (title-like-contract)
(->* ()
(#:tag (or/c #f string? (listof string?))
#:tag-prefix (or/c #f string? module-path?)
#:style (or/c style? string? symbol? (listof symbol?) #f))
#:rest (listof pre-content?)
part-start?))
(provide/contract
[title (->* ()
(#:tag (or/c #f string? (listof string?))
#:tag-prefix (or/c #f string? module-path?)
#:style (or/c style? string? symbol? (listof symbol?) #f)
#:version (or/c string? #f))
#:rest (listof pre-content?)
title-decl?)]
[section (title-like-contract)]
[subsection (title-like-contract)]
[subsubsection (title-like-contract)]
[subsubsub*section (->* ()
(#:tag (or/c #f string? (listof string?)))
#:rest (listof pre-content?)
block?)])
(provide include-section)
(define (gen-tag content)
(regexp-replace* "[^-a-zA-Z0-9_=]" (content->string content) "_"))
(define (prefix->string p)
(and p (if (string? p) p (module-path-prefix->string p))))
(define (convert-tag tag content)
(if (list? tag)
(append-map (lambda (t) (convert-tag t content)) tag)
`((part ,(or tag (gen-tag content))))))
(define (convert-part-style who s)
(cond
[(style? s) s]
[(not s) plain]
[(string? s) (make-style s null)]
[(symbol? s) (make-style #f (list s))]
[(and (list? s) (andmap symbol? s)) (make-style #f s)]
[else (raise-type-error who "style, string, symbol, list of symbols, or #f" s)]))
(define (title #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style plain]
#:version [version #f] . str)
(let ([content (decode-content str)])
(make-title-decl (prefix->string prefix)
(convert-tag tag content)
version
(convert-part-style 'title style)
content)))
(define (section #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style plain]
. str)
(let ([content (decode-content str)])
(make-part-start 0 (prefix->string prefix)
(convert-tag tag content)
(convert-part-style 'section style)
content)))
(define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style plain]
. str)
(let ([content (decode-content str)])
(make-part-start 1
(prefix->string prefix)
(convert-tag tag content)
(convert-part-style 'subsection style)
content)))
(define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f]
#:style [style plain] . str)
(let ([content (decode-content str)])
(make-part-start 2
(prefix->string prefix)
(convert-tag tag content)
(convert-part-style 'subsubsection style)
content)))
(define (subsubsub*section #:tag [tag #f] . str)
(let ([content (decode-content str)])
(make-paragraph plain
(list
(make-element 'bold
(if tag
(make-target-element #f content `(part ,tag))
content))))))
(define-syntax (include-section stx)
(syntax-case stx ()
[(_ mod)
(with-syntax ([mod (syntax-local-introduce #'mod)])
(unless (module-path? (syntax->datum #'mod))
(raise-syntax-error #f
"not a module path"
stx
#'mod))
#'(begin
(require (only-in mod doc))
doc))]))
;; ----------------------------------------
(provide/contract
[author (->* (content?) () #:rest (listof content?) block?)]
[author+email (-> content? string? element?)])
(define (author . auths)
(make-paragraph
(make-style 'author null)
(let ([nl (make-element 'newline '("\n"))])
(case (length auths)
[(1) auths]
[(2) (list (car auths) nl "and " (cadr auths))]
[else (let ([r (reverse auths)])
(append (add-between (reverse (cdr r))
(make-element #f (list "," nl)))
(list "," nl "and " (car r))))]))))
(define (author+email name email)
(make-element #f
(list
name
" <"
(regexp-replace* #rx"[.]"
(regexp-replace* #rx"@" email " at ")
" dot ")
">")))
;; ----------------------------------------
(provide intern-taglet
module-path-index->taglet
module-path-prefix->string
doc-prefix)
(require syntax/modcollapse
;; Needed to normalize planet version numbers:
(only-in planet/resolver get-planet-module-path/pkg)
(only-in planet/private/data pkg-maj pkg-min))
(define interned (make-weak-hash))
(define (intern-taglet v)
(let ([v (if (list? v)
(map intern-taglet v)
v)])
(if (or (string? v)
(bytes? v)
(list? v))
(let ([b (hash-ref interned v #f)])
(if b
(or (weak-box-value b)
;; just in case the value is GCed before we extract it:
(intern-taglet v))
(begin
(hash-set! interned v (make-weak-box v))
v)))
v)))
(define (do-module-path-index->taglet mod)
;; Derive the name from the module path:
(let ([p (collapse-module-path-index
mod
(lambda () (build-path (current-directory) "dummy")))])
(if (path? p)
;; If we got a path back anyway, then it's best to use the resolved
;; name; if the current directory has changed since we
;; the path-index was resolved, then p might not be right. Also,
;; the resolved path might be a symbol instead of a path.
(let ([rp (resolved-module-path-name
(module-path-index-resolve mod))])
(if (path? rp)
(intern-taglet
(path->main-collects-relative rp))
rp))
(let ([p (if (and (pair? p)
(eq? (car p) 'planet))
;; Normalize planet verion number based on current
;; linking:
(let-values ([(path pkg)
(get-planet-module-path/pkg p #f #f)])
(list* 'planet
(cadr p)
(list (car (caddr p))
(cadr (caddr p))
(pkg-maj pkg)
(pkg-min pkg))
(cdddr p)))
;; Otherwise the path is fully normalized:
p)])
(intern-taglet p)))))
(define collapsed (make-weak-hasheq))
(define (module-path-index->taglet mod)
(or (hash-ref collapsed mod #f)
(let ([v (do-module-path-index->taglet mod)])
(hash-set! collapsed mod v)
v)))
(define (module-path-prefix->string p)
(format "~a" (module-path-index->taglet (module-path-index-join p #f))))
(define doc-prefix
(case-lambda
[(doc s)
(if doc
(list (module-path-prefix->string doc) s)
s)]
[(doc prefix s)
(doc-prefix doc (if prefix
(append prefix (list s))
s))]))
;; ----------------------------------------
(define (item? x) (an-item? x))
(provide/contract
[itemlist (->* ()
(#:style (or/c style? string? symbol? #f))
#:rest (listof item?)
itemization?)]
[item (->* ()
()
#:rest (listof pre-flow?)
item?)])
(provide item?)
(define (itemlist #:style [style plain] . items)
(let ([flows (map an-item-flow items)])
(make-itemization (convert-block-style style) flows)))
(define-struct an-item (flow))
(define (item . str)
(make-an-item (decode-flow str)))
;; ----------------------------------------
(define elem-like-contract
(->* () () #:rest (listof pre-content?) element?))
(provide/contract
[hspace (-> exact-nonnegative-integer? element?)]
[elem (->* ()
(#:style element-style?)
#:rest (listof pre-content?)
element?)]
[italic elem-like-contract]
[bold elem-like-contract]
[smaller elem-like-contract]
[larger elem-like-contract]
[emph elem-like-contract]
[tt elem-like-contract]
[subscript elem-like-contract]
[superscript elem-like-contract]
[literal (->* (string?) () #:rest (listof string?) element?)]
[image (->* ((or/c path-string? (cons/c 'collects (listof bytes?))))
(#:scale real?
#:suffixes (listof #rx"^[.]"))
#:rest (listof content?)
image-element?)])
(define hspace-cache (make-vector 100 #f))
(define (hspace n)
(if (n . < . (vector-length hspace-cache))
(or (vector-ref hspace-cache n)
(let ([h (make-element 'hspace (list (make-string n #\space)))])
(vector-set! hspace-cache n h)
h))
(make-element 'hspace (list (make-string n #\space)))))
(define (elem #:style [style plain] . str)
(make-element style (decode-content str)))
(define (italic . str)
(make-element 'italic (decode-content str)))
(define (bold . str)
(make-element 'bold (decode-content str)))
(define (smaller . str)
(make-element 'smaller (decode-content str)))
(define (larger . str)
(make-element 'larger (decode-content str)))
(define (emph . str)
(make-element 'italic (decode-content str)))
(define (tt . str)
(let* ([l (decode-content str)]
[l (let ([m (and (pair? l)
(string? (car l))
(regexp-match-positions #rx"^ +" (car l)))])
(if m
(list* (hspace (- (cdar m) (caar m)))
(substring (car l) (cdar m))
(cdr l))
l))])
(if (andmap string? l)
(make-element 'tt l)
(make-element #f (map (lambda (s)
(if (or (string? s) (symbol? s))
(make-element 'tt (list s))
s))
l)))))
(define (span-class classname . str)
(make-element classname (decode-content str)))
(define (subscript . str)
(make-element 'subscript (decode-content str)))
(define (superscript . str)
(make-element 'superscript (decode-content str)))
(define (literal s . strs)
(let ([s (apply string-append s strs)])
(make-element #f s)))
(define (image #:scale [scale 1.0]
filename-relative-to-source
#:suffixes [suffixes null]
. alt)
(make-image-element #f
(decode-content alt)
filename-relative-to-source
suffixes
scale))
;; ----------------------------------------
(provide/contract
[para (->* ()
(#:style (or/c style? string? symbol? #f ))
#:rest (listof pre-content?)
paragraph?)]
[nested (->* ()
(#:style (or/c style? string? symbol? #f ))
#:rest (listof pre-flow?)
nested-flow?)]
[compound (->* ()
(#:style (or/c style? string? symbol? #f ))
#:rest (listof pre-flow?)
compound-paragraph?)]
[tabular (->* ((listof (listof (or/c 'cont block? content?))))
(#:style (or/c style? string? symbol? #f ))
table?)])
(define (convert-block-style style)
(cond
[(style? style) style]
[(or (string? style) (symbol? style)) (make-style style null)]
[else plain]))
(define (nested #:style [style #f] . c)
(make-nested-flow (convert-block-style style)
(decode-flow c)))
(define (para #:style [style #f] . c)
(make-paragraph (convert-block-style style)
(decode-content c)))
(define (compound #:style [style #f] . c)
(make-compound-paragraph (convert-block-style style)
(decode-flow c)))
(define (tabular #:style [style #f] cells)
(define (nth-str pos)
(case (modulo pos 10)
[(1) "st"]
[(2) "nd"]
[(3) "rd"]
[else "th"]))
(unless (null? cells)
(let ([n (length (car cells))])
(for ([row (in-list (cdr cells))]
[pos (in-naturals 2)])
(unless (= n (length row))
(raise-mismatch-error
'tabular
(format "bad length (~a does not match first row's length ~a) for ~a~a row: "
(length row)
n
pos
(nth-str pos))
row)))))
(for ([row (in-list cells)]
[pos (in-naturals 1)])
(when (and (pair? row) (eq? (car row) 'cont))
(raise-mismatch-error
'tabular
(format "~a~a row starts with 'cont: " pos (nth-str pos))
row)))
(make-table (convert-block-style style)
(map (lambda (row)
(map (lambda (cell)
(cond
[(eq? cell 'cont) cell]
[(block? cell) cell]
[else (make-paragraph plain cell)]))
row))
cells)))
;; ----------------------------------------
(provide/contract
[elemtag (->* ((or/c tag? string?))
()
#:rest (listof pre-content?)
element?)]
[elemref (->* ((or/c tag? string?))
(#:underline? any/c)
#:rest (listof pre-content?)
element?)]
[secref (->* (string?)
(#:doc module-path?
#:tag-prefixes (or/c #f (listof string))
#:underline? any/c)
element?)]
[Secref (->* (string?)
(#:doc module-path?
#:tag-prefixes (or/c #f (listof string))
#:underline? any/c)
element?)]
[seclink (->* (string?)
(#:doc module-path?
#:tag-prefixes (or/c #f (listof string))
#:underline? any/c)
#:rest (listof pre-content?)
element?)]
[other-doc (->* (module-path?)
(#:underline? any/c)
element?)])
(define (elemtag t . body)
(make-target-element #f (decode-content body) `(elem ,t)))
(define (elemref #:underline? [u? #t] t . body)
(make-link-element (if u? #f "plainlink") (decode-content body) `(elem ,t)))
(define (secref s #:underline? [u? #t] #:doc [doc #f] #:tag-prefixes [prefix #f])
(make-link-element (if u? #f "plainlink") null `(part ,(doc-prefix doc prefix s))))
(define (Secref s #:underline? [u? #t] #:doc [doc #f] #:tag-prefixes [prefix #f])
(let ([le (secref s #:underline? u? #:doc doc #:tag-prefixes prefix)])
(make-link-element
(make-style (element-style le) '(uppercase))
(element-content le)
(link-element-tag le))))
(define (seclink tag #:underline? [u? #t] #:doc [doc #f] #:tag-prefixes [prefix #f] . s)
(make-link-element (if u? #f "plainlink") (decode-content s)
`(part ,(doc-prefix doc prefix tag))))
(define (other-doc #:underline? [u? #t] doc)
(secref #:doc doc #:underline? u? "top"))
;; ----------------------------------------
(provide/contract
[hyperlink (->* ((or/c string? path?))
(#:underline? any/c
#:style element-style?)
#:rest (listof pre-content?)
element?)]
[url (-> string? element?)]
[margin-note (->* () () #:rest (listof pre-flow?) block?)]
[centered (->* () () #:rest (listof pre-flow?) block?)]
[verbatim (->* (string?) (#:indent exact-nonnegative-integer?) #:rest (listof string?) block?)])
(define (centered . s)
(make-nested-flow (make-style "SCentered" null) (decode-flow s)))
(define (hyperlink url
#:underline? [underline? #t]
#:style [style (if underline? #f "plainlink")]
. str)
(make-element (make-style (if (style? style)
(style-name style)
style)
(cons (make-target-url url)
(if (style? style)
(style-variants style)
null)))
(decode-content str)))
(define (url str)
(hyperlink str (make-element 'url str)))
(define (margin-note . c)
(make-nested-flow
(make-style "refpara" '(command))
(list
(make-nested-flow
(make-style "refcolumn" null)
(list
(make-nested-flow
(make-style "refcontent" null)
(decode-flow c)))))))
(define (verbatim #:indent [i 0] s . more)
(define indent
(if (zero? i)
values
(let ([hs (hspace i)]) (lambda (x) (cons hs x)))))
(define strs (regexp-split #rx"\n" (apply string-append s more)))
(define (str->elts str)
(let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)])
(if spaces
(list* (substring str 0 (caar spaces))
(hspace (- (cdar spaces) (caar spaces)))
(str->elts (substring str (cdar spaces))))
(list (make-element 'tt (list str))))))
(define (make-nonempty l)
(if (let loop ([l l])
(cond
[(null? l) #t]
[(equal? "" l) #t]
[(list? l) (andmap loop l)]
[(element? l) (loop (element-content l))]
[(multiarg-element? l) (loop (multiarg-element-contents l))]
[else #f]))
(list l (hspace 1))
l))
(define (make-line str)
(let* ([line (indent (str->elts str))]
[line (list (make-element 'tt line))])
(list (make-paragraph omitable-style (make-nonempty line)))))
(make-table plain (map make-line strs)))
(define omitable-style (make-style 'omitable null))
;; ----------------------------------------
(provide section-index index index* as-index index-section
get-index-entries index-block)
(define (section-index . elems)
(make-part-index-decl (map content->string elems) elems))
(define (record-index word-seq element-seq tag content)
(make-index-element #f
(list (make-target-element #f content `(idx ,tag)))
`(idx ,tag)
word-seq
element-seq
#f))
(define (index* word-seq content-seq . s)
(let ([key (make-generated-tag)])
(record-index (map clean-up-index-string word-seq)
content-seq key (decode-content s))))
(define (index word-seq . s)
(let ([word-seq (if (string? word-seq) (list word-seq) word-seq)])
(apply index* word-seq word-seq s)))
(define (as-index . s)
(let ([key (make-generated-tag)]
[content (decode-content s)])
(record-index
(list (clean-up-index-string (content->string content)))
(if (= 1 (length content)) content (list (make-element #f content)))
key
content)))
(define (index-section #:title [title "Index"] #:tag [tag #f])
(make-part #f
`((part ,(or tag "doc-index")))
(list title)
(make-style 'index '(unnumbered))
null
(list (index-block))
null))
;; returns an ordered list of (list tag (text ...) (element ...) index-desc)
(define (get-index-entries sec ri)
(define (compare-lists xs ys <?)
(let loop ([xs xs] [ys ys])
(cond [(and (null? xs) (null? ys)) '=]
[(null? xs) '<]
[(null? ys) '>]
[(<? (car xs) (car ys)) '<]
[(<? (car ys) (car xs)) '>]
[else (loop (cdr ys) (cdr xs))])))
;; string-ci<? as a major key, and string<? next, so "Foo" precedes "foo"
;; (define (string*<? s1 s2)
;; (or (string-ci<? s1 s2)
;; (and (not (string-ci<? s2 s1)) (string<? s1 s2))))
(define (get-desc entry)
(let ([desc (cadddr entry)])
(cond [(exported-index-desc? desc)
(cons 'libs (map (lambda (l)
(format "~s" l))
(exported-index-desc-from-libs desc)))]
[(module-path-index-desc? desc) '(mod)]
[(part-index-desc? desc) '(part)]
[(delayed-index-desc? desc) '(delayed)]
[else '(#f)])))
;; parts first, then modules, then bindings, delayed means it's not
;; the last round, and #f means no desc
(define desc-order '(part mod libs delayed #f))
;; this defines an imposed ordering for module names
(define lib-order '(#rx"^scheme(?:/|$)" #rx"^r.rs(?:/|$)" #rx"^lang(?:/|$)"))
(define (lib<? lib1 lib2)
(define (lib-level lib)
(let loop ([i 0] [rxs lib-order])
(if (or (null? rxs) (regexp-match? (car rxs) lib))
i (loop (add1 i) (cdr rxs)))))
(let ([l1 (lib-level lib1)] [l2 (lib-level lib2)])
(if (= l1 l2) (string<? lib1 lib2) (< l1 l2))))
(define (compare-desc e1 e2)
(let* ([d1 (get-desc e1)] [d2 (get-desc e2)]
[t1 (car d1)] [t2 (car d2)])
(cond [(memq t2 (cdr (memq t1 desc-order))) '<]
[(memq t1 (cdr (memq t2 desc-order))) '>]
[else (case t1 ; equal to t2
[(part) '=] ; will just compare tags
[(mod) '=] ; the text fields are the names of the modules
[(libs) (compare-lists (cdr d1) (cdr d2) lib<?)]
[(delayed) '>] ; dosn't matter, will run again
[(#f) '=])])))
(define (entry<? e1 e2)
(let ([text1 (cadr e1)] [text2 (cadr e2)])
(case (compare-lists text1 text2 string-ci<?)
[(<) #t] [(>) #f]
[else (case (compare-desc e1 e2)
[(<) #t] [(>) #f]
[else (case (compare-lists text1 text2 string<?)
[(<) #t] [(>) #f]
[else
;; (error 'get-index-entries
;; ;; when this happens, revise this code so
;; ;; ordering will always be deterministic
;; "internal error -- unordered entries: ~e ~e"
;; e1 e2)
;; Instead, just compare the tags
(string<? (format "~a" (car e1))
(format "~a" (car e2)))])])])))
(define l null)
(hash-for-each
(let ([parent (collected-info-parent (part-collected-info sec ri))])
(if parent
(collected-info-info (part-collected-info parent ri))
(collect-info-ext-ht (resolve-info-ci ri))))
(lambda (k v)
(when (and (pair? k) (eq? 'index-entry (car k)))
(set! l (cons (cons (cadr k) v) l)))))
(sort l entry<?))
(define (index-block)
(define alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
(define (rows . rows)
(make-table (make-style 'index null)
(map (lambda (row)
(list (make-paragraph plain row)))
rows)))
(define contents
(lambda (renderer sec ri)
(define l (get-index-entries sec ri))
(define manual-newlines? (send renderer index-manual-newlines?))
(define alpha-starts (make-hasheq))
(define alpha-row
(let loop ([i l] [alpha alpha])
(define (add-letter let l)
(list* (make-element "nonavigation" (list (string let))) " " l))
(cond [(null? alpha) null]
[(null? i) (add-letter (car alpha) (loop i (cdr alpha)))]
[else
(let* ([strs (cadr (car i))]
[letter (if (or (null? strs) (string=? "" (car strs)))
#f
(char-upcase (string-ref (car strs) 0)))])
(cond [(not letter) (loop (cdr i) alpha)]
[(char-ci>? letter (car alpha))
(add-letter (car alpha) (loop i (cdr alpha)))]
[(char-ci=? letter (car alpha))
(hash-set! alpha-starts (car i) letter)
(list* (make-element
(make-style #f (list (make-target-url (format "#alpha:~a" letter))))
(list (string (car alpha))))
" "
(loop (cdr i) (cdr alpha)))]
[else (loop (cdr i) alpha)]))])))
(define body
(let ([br (if manual-newlines? (make-element 'newline '("\n")) "")])
(map (lambda (i)
(let ([e (make-link-element
"indexlink"
`(,@(add-between (caddr i) ", ") ,br)
(car i))])
(cond [(hash-ref alpha-starts i #f)
=> (lambda (let)
(make-element
(make-style #f (list
(make-url-anchor
(format "alpha:~a" (char-upcase let)))))
(list e)))]
[else e])))
l)))
(if manual-newlines?
(rows alpha-row '(nbsp) body)
(apply rows alpha-row '(nbsp) (map list body)))))
(make-delayed-block contents))
;; ----------------------------------------
(provide table-of-contents
local-table-of-contents)
(define (table-of-contents)
(make-delayed-block
(lambda (renderer part ri)
(send renderer table-of-contents part ri))))
(define (local-table-of-contents #:style [style plain])
(make-delayed-block
(lambda (renderer part ri)
(send renderer local-table-of-contents part ri style))))

4
collects/scribble/base/lang.ss Normal file
View File

@ -0,0 +1,4 @@
#lang scheme
(require scribble/doclang scribble/base)
(provide (all-from-out scribble/doclang
scribble/base))

10
collects/scribble/base/lang/reader.ss Normal file
View File

@ -0,0 +1,10 @@
#lang s-exp syntax/module-reader
scribble/base/lang
#:read scribble:read-inside
#:read-syntax scribble:read-syntax-inside
#:whole-body-readers? #t
#:wrapper1 (lambda (t) (list* 'doc 'values '() (t)))
(require (prefix-in scribble: "../../reader.ss"))

441
collects/scribble/basic.ss
View File

@ -1,443 +1,46 @@
#lang scheme/base #lang scheme/base
(require "decode.ss" (require "base.ss"
"struct.ss" "core.ss"
"config.ss" "decode.ss")
"manual-struct.ss"
"decode-struct.ss"
scheme/list
scheme/class
setup/main-collects
syntax/modresolve
(for-syntax scheme/base))
(provide title (provide title
section section
subsection subsection
subsubsection subsubsection
subsubsub*section subsubsub*section
include-section) include-section
(define (gen-tag content) author
(regexp-replace* "[^-a-zA-Z0-9_=]" (content->string content) "_")) author+email
(define (prefix->string p) intern-taglet
(and p (if (string? p) p (module-path-prefix->string p))))
(define (convert-tag tag content)
(if (list? tag)
(append-map (lambda (t) (convert-tag t content)) tag)
`((part ,(or tag (gen-tag content))))))
(define (title #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f]
#:version [version #f] . str)
(let ([content (decode-content str)])
(make-title-decl (prefix->string prefix)
(convert-tag tag content)
version
style
content)))
(define (section #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f]
. str)
(let ([content (decode-content str)])
(make-part-start 0 (prefix->string prefix)
(convert-tag tag content)
style
content)))
(define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f]
. str)
(let ([content (decode-content str)])
(make-part-start 1
(prefix->string prefix)
(convert-tag tag content)
style
content)))
(define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f]
#:style [style #f] . str)
(let ([content (decode-content str)])
(make-part-start 2
(prefix->string prefix)
(convert-tag tag content)
style
content)))
(define (subsubsub*section #:tag [tag #f] . str)
(let ([content (decode-content str)])
(make-paragraph (list (make-element 'bold content)))))
(define-syntax (include-section stx)
(syntax-case stx ()
[(_ mod)
(with-syntax ([mod (syntax-local-introduce #'mod)])
#'(begin
(require (only-in mod doc))
doc))]))
;; ----------------------------------------
(provide author
author+email)
(define (author . auths)
(make-styled-paragraph
(let ([nl (make-element 'newline '("\n"))])
(case (length auths)
[(1) auths]
[(2) (list (car auths) nl "and " (cadr auths))]
[else (let ([r (reverse auths)])
(append (add-between (reverse (cdr r))
(make-element #f (list "," nl)))
(list "," nl "and " (car r))))]))
"author"))
(define (author+email name email)
(make-element #f
(list
name
" <"
(regexp-replace* #rx"[.]"
(regexp-replace* #rx"@" email " at ")
" dot ")
">")))
;; ----------------------------------------
(provide intern-taglet
module-path-index->taglet module-path-index->taglet
module-path-prefix->string) module-path-prefix->string
(define interned (make-weak-hash)) itemize item item?
(define (intern-taglet v) hspace
(let ([v (if (list? v)
(map intern-taglet v)
v)])
(if (or (string? v)
(bytes? v)
(list? v))
(let ([b (hash-ref interned v #f)])
(if b
(or (weak-box-value b)
;; just in case the value is GCed before we extract it:
(intern-taglet v))
(begin
(hash-set! interned v (make-weak-box v))
v)))
v)))
(define (do-module-path-index->taglet mod)
;; Derive the name from the module path:
(let ([p (collapse-module-path-index
mod
(lambda () (build-path (current-directory) "dummy")))])
(if (path? p)
;; If we got a path back anyway, then it's best to use the resolved
;; name; if the current directory has changed since we
;; the path-index was resolved, then p might not be right. Also,
;; the resolved path might be a symbol instead of a path.
(let ([rp (resolved-module-path-name
(module-path-index-resolve mod))])
(if (path? rp)
(intern-taglet
(path->main-collects-relative rp))
rp))
(let ([p (if (and (pair? p)
(eq? (car p) 'planet))
;; Normalize planet verion number based on current
;; linking:
(let-values ([(path pkg)
(get-planet-module-path/pkg p #f #f)])
(list* 'planet
(cadr p)
(list (car (caddr p))
(cadr (caddr p))
(pkg-maj pkg)
(pkg-min pkg))
(cdddr p)))
;; Otherwise the path is fully normalized:
p)])
(intern-taglet p)))))
(define collapsed (make-weak-hasheq))
(define (module-path-index->taglet mod)
(or (hash-ref collapsed mod #f)
(let ([v (do-module-path-index->taglet mod)])
(hash-set! collapsed mod v)
v)))
(define (module-path-prefix->string p)
(format "~a" (module-path-index->taglet (module-path-index-join p #f))))
;; ----------------------------------------
(require syntax/modcollapse
;; Needed to normalize planet version numbers:
(only-in planet/resolver get-planet-module-path/pkg)
(only-in planet/private/data pkg-maj pkg-min))
(provide itemize item item?)
(define (itemize #:style [style #f] . items)
(let ([items (filter (lambda (v) (not (whitespace? v))) items)])
(for ([v items])
(unless (an-item? v)
(error 'itemize "expected an item, found something else: ~e" v)))
(let ([flows (map an-item-flow items)])
(if style
(make-styled-itemization flows style)
(make-itemization flows)))))
(define-struct an-item (flow))
(define (item? x) (an-item? x))
(define (item . str)
(make-an-item (decode-flow str)))
;; ----------------------------------------
(provide hspace
elem aux-elem elem aux-elem
italic bold smaller italic bold smaller
tt span-class tt
subscript superscript) subscript superscript
(define hspace-cache (make-vector 100 #f)) section-index index index* as-index index-section
get-index-entries index-block
(define (hspace n) table-of-contents
(if (n . < . (vector-length hspace-cache)) local-table-of-contents
(or (vector-ref hspace-cache n)
(let ([h (make-element 'hspace (list (make-string n #\space)))])
(vector-set! hspace-cache n h)
h))
(make-element 'hspace (list (make-string n #\space)))))
(define (elem #:style [style #f] . str) span-class)
(make-element style (decode-content str)))
(define (aux-elem . s)
(make-aux-element #f (decode-content s)))
(define (italic . str)
(make-element 'italic (decode-content str)))
(define (bold . str)
(make-element 'bold (decode-content str)))
(define (smaller . str)
(make-element "smaller" (decode-content str)))
(define (tt . str)
(let* ([l (decode-content str)]
[l (let ([m (and (pair? l)
(string? (car l))
(regexp-match-positions #rx"^ +" (car l)))])
(if m
(list* (hspace (- (cdar m) (caar m)))
(substring (car l) (cdar m))
(cdr l))
l))])
(if (andmap string? l)
(make-element 'tt l)
(make-element #f (map (lambda (s)
(if (or (string? s) (symbol? s))
(make-element 'tt (list s))
s))
l)))))
(define (span-class classname . str) (define (span-class classname . str)
(make-element classname (decode-content str))) (make-element classname (decode-content str)))
(define (subscript . str) (define (aux-elem . s)
(make-element 'subscript (decode-content str))) (make-element (make-style #f (list 'aux)) (decode-content s)))
(define (superscript . str) (define (itemize #:style [style #f] . items)
(make-element 'superscript (decode-content str))) (let ([items (filter (lambda (v) (not (whitespace? v))) items)])
(apply itemlist #:style style items)))
;; ----------------------------------------
(provide section-index index index* as-index index-section
get-index-entries index-block)
(define (section-index . elems)
(make-part-index-decl (map element->string elems) elems))
(define (record-index word-seq element-seq tag content)
(make-index-element #f
(list (make-target-element #f content `(idx ,tag)))
`(idx ,tag)
word-seq
element-seq
#f))
(define (index* word-seq content-seq . s)
(let ([key (make-generated-tag)])
(record-index (map clean-up-index-string word-seq)
content-seq key (decode-content s))))
(define (index word-seq . s)
(let ([word-seq (if (string? word-seq) (list word-seq) word-seq)])
(apply index* word-seq word-seq s)))
(define (as-index . s)
(let ([key (make-generated-tag)]
[content (decode-content s)])
(record-index
(list (clean-up-index-string (content->string content)))
(if (= 1 (length content)) content (list (make-element #f content)))
key
content)))
(define (index-section #:title [title "Index"] #:tag [tag #f])
(make-unnumbered-part #f
`((part ,(or tag "doc-index")))
(list title)
'index
null
(make-flow (list (index-block)))
null))
;; returns an ordered list of (list tag (text ...) (element ...) index-desc)
(define (get-index-entries sec ri)
(define (compare-lists xs ys <?)
(let loop ([xs xs] [ys ys])
(cond [(and (null? xs) (null? ys)) '=]
[(null? xs) '<]
[(null? ys) '>]
[(<? (car xs) (car ys)) '<]
[(<? (car ys) (car xs)) '>]
[else (loop (cdr ys) (cdr xs))])))
;; string-ci<? as a major key, and string<? next, so "Foo" precedes "foo"
;; (define (string*<? s1 s2)
;; (or (string-ci<? s1 s2)
;; (and (not (string-ci<? s2 s1)) (string<? s1 s2))))
(define (get-desc entry)
(let ([desc (cadddr entry)])
(cond [(exported-index-desc? desc)
(cons 'libs (map (lambda (l)
(format "~s" l))
(exported-index-desc-from-libs desc)))]
[(module-path-index-desc? desc) '(mod)]
[(part-index-desc? desc) '(part)]
[(delayed-index-desc? desc) '(delayed)]
[else '(#f)])))
;; parts first, then modules, then bindings, delayed means it's not
;; the last round, and #f means no desc
(define desc-order '(part mod libs delayed #f))
;; this defines an imposed ordering for module names
(define lib-order '(#rx"^scheme(?:/|$)" #rx"^r.rs(?:/|$)" #rx"^lang(?:/|$)"))
(define (lib<? lib1 lib2)
(define (lib-level lib)
(let loop ([i 0] [rxs lib-order])
(if (or (null? rxs) (regexp-match? (car rxs) lib))
i (loop (add1 i) (cdr rxs)))))
(let ([l1 (lib-level lib1)] [l2 (lib-level lib2)])
(if (= l1 l2) (string<? lib1 lib2) (< l1 l2))))
(define (compare-desc e1 e2)
(let* ([d1 (get-desc e1)] [d2 (get-desc e2)]
[t1 (car d1)] [t2 (car d2)])
(cond [(memq t2 (cdr (memq t1 desc-order))) '<]
[(memq t1 (cdr (memq t2 desc-order))) '>]
[else (case t1 ; equal to t2
[(part) '=] ; will just compare tags
[(mod) '=] ; the text fields are the names of the modules
[(libs) (compare-lists (cdr d1) (cdr d2) lib<?)]
[(delayed) '>] ; dosn't matter, will run again
[(#f) '=])])))
(define (entry<? e1 e2)
(let ([text1 (cadr e1)] [text2 (cadr e2)])
(case (compare-lists text1 text2 string-ci<?)
[(<) #t] [(>) #f]
[else (case (compare-desc e1 e2)
[(<) #t] [(>) #f]
[else (case (compare-lists text1 text2 string<?)
[(<) #t] [(>) #f]
[else
;; (error 'get-index-entries
;; ;; when this happens, revise this code so
;; ;; ordering will always be deterministic
;; "internal error -- unordered entries: ~e ~e"
;; e1 e2)
;; Instead, just compare the tags
(string<? (format "~a" (car e1))
(format "~a" (car e2)))])])])))
(define l null)
(hash-for-each
(let ([parent (collected-info-parent (part-collected-info sec ri))])
(if parent
(collected-info-info (part-collected-info parent ri))
(collect-info-ext-ht (resolve-info-ci ri))))
(lambda (k v)
(when (and (pair? k) (eq? 'index-entry (car k)))
(set! l (cons (cons (cadr k) v) l)))))
(sort l entry<?))
(define (index-block)
(define alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
(define (rows . rows)
(make-table 'index (map (lambda (row)
(list (make-flow (list (make-paragraph row)))))
rows)))
(define contents
(lambda (renderer sec ri)
(define l (get-index-entries sec ri))
(define manual-newlines? (send renderer index-manual-newlines?))
(define alpha-starts (make-hasheq))
(define alpha-row
(let loop ([i l] [alpha alpha])
(define (add-letter let l)
(list* (make-element "nonavigation" (list (string let))) " " l))
(cond [(null? alpha) null]
[(null? i) (add-letter (car alpha) (loop i (cdr alpha)))]
[else
(let* ([strs (cadr (car i))]
[letter (if (or (null? strs) (string=? "" (car strs)))
#f
(char-upcase (string-ref (car strs) 0)))])
(cond [(not letter) (loop (cdr i) alpha)]
[(char-ci>? letter (car alpha))
(add-letter (car alpha) (loop i (cdr alpha)))]
[(char-ci=? letter (car alpha))
(hash-set! alpha-starts (car i) letter)
(list* (make-element
(make-target-url (format "#alpha:~a" letter)
#f)
(list (string (car alpha))))
" "
(loop (cdr i) (cdr alpha)))]
[else (loop (cdr i) alpha)]))])))
(define body
(let ([br (if manual-newlines? (make-element 'newline '("\n")) "")])
(map (lambda (i)
(let ([e (make-link-element
"indexlink"
`(,@(add-between (caddr i) ", ") ,br)
(car i))])
(cond [(hash-ref alpha-starts i #f)
=> (lambda (let)
(make-element
(make-url-anchor
(format "alpha:~a" (char-upcase let)))
(list e)))]
[else e])))
l)))
(if manual-newlines?
(rows alpha-row '(nbsp) body)
(apply rows alpha-row '(nbsp) (map list body)))))
(make-delayed-block contents))
;; ----------------------------------------
(provide table-of-contents
local-table-of-contents)
(define (table-of-contents)
(make-delayed-block
(lambda (renderer part ri)
(send renderer table-of-contents part ri))))
(define (local-table-of-contents #:style [style #f])
(make-delayed-block
(lambda (renderer part ri)
(send renderer local-table-of-contents part ri style))))

532
collects/scribble/core.ss Normal file
View File

@ -0,0 +1,532 @@
#lang scheme/base
(require "private/provide-structs.ss"
scheme/serialize
scheme/contract)
;; ----------------------------------------
(define-struct collect-info (ht ext-ht parts tags gen-prefix relatives parents))
(define-struct resolve-info (ci delays undef searches))
(define (part-collected-info part ri)
(hash-ref (collect-info-parts (resolve-info-ci ri))
part))
(define (collect-put! ci key val)
(let ([ht (collect-info-ht ci)])
(let ([old-val (hash-ref ht key #f)])
(when old-val
(fprintf (current-error-port)
"WARNING: collected information for key multiple times: ~e; values: ~e ~e\n"
key old-val val))
(hash-set! ht key val))))
(define (resolve-get/where part ri key)
(let ([key (tag-key key ri)])
(let ([v (hash-ref (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
(values (hash-ref (collect-info-ext-ht (resolve-info-ci ri)) key #f)
#t)]))))
(define (resolve-get/ext? part ri key)
(let-values ([(v ext?) (resolve-get/where part ri key)])
(when ext?
(hash-set! (resolve-info-undef ri) (tag-key key ri) #t))
(values v ext?)))
(define (resolve-get part ri key)
(let-values ([(v ext?) (resolve-get/ext? part ri key)])
v))
(define (resolve-get/tentative part ri key)
(let-values ([(v ext?) (resolve-get/where part ri key)])
v))
(define (resolve-search search-key part ri key)
(let ([s-ht (hash-ref (resolve-info-searches ri)
search-key
(lambda ()
(let ([s-ht (make-hash)])
(hash-set! (resolve-info-searches ri)
search-key s-ht)
s-ht)))])
(hash-set! s-ht key #t))
(resolve-get part ri key))
(define (resolve-get-keys part ri key-pred)
(let ([l null])
(hash-for-each
(collected-info-info (part-collected-info part ri))
(lambda (k v) (when (key-pred k) (set! l (cons k l)))))
l))
(provide (struct-out collect-info)
(struct-out resolve-info))
;; ----------------------------------------
(provide tag?)
(define (tag? s)
(and (pair? s)
(symbol? (car s))
(pair? (cdr s))
(or (string? (cadr s))
(generated-tag? (cadr s))
(and (pair? (cadr s))
(list? (cadr s))))
(null? (cddr s))))
(provide block?)
(define (block? p)
(or (paragraph? p)
(table? p)
(itemization? p)
(nested-flow? p)
(compound-paragraph? p)
(delayed-block? p)))
(define content-symbols
#hasheq([nbsp . #t]
[mdash . #t]
[ndash . #t]
[ldquo . #t]
[rdquo . #t]
[rsquo . #t]
[prime . #t]
[rarr . #t]
[larr . #t]
[alpha . #t]
[infin . #t]
[lang . #t]
[rang . #t]))
(provide content?)
(define (content? v)
(or (string? v)
(element? v)
(and (list? v) (andmap content? v))
(delayed-element? v)
(part-relative-element? v)
(multiarg-element? v)
(hash-ref content-symbols v #f)))
(provide element-style?)
(define (element-style? s)
(or (style? s) (not s) (string? s) (symbol? s)))
(define (string-without-newline? s)
(and (string? s)
(not (regexp-match? #rx"\n" s))))
(provide-structs
[part ([tag-prefix (or/c false/c string?)]
[tags (listof tag?)]
[title-content (or/c false/c content?)]
[style style?]
[to-collect list?]
[blocks (listof block?)]
[parts (listof part?)])]
[paragraph ([style style?]
[content content?])]
[table ([style style?]
[blockss (listof (listof (or/c block? (one-of/c 'cont))))])]
[delayed-block ([resolve (any/c part? resolve-info? . -> . block?)])]
[itemization ([style style?]
[blockss (listof (listof block?))])]
[nested-flow ([style style?]
[blocks (listof block?)])]
[compound-paragraph ([style style?]
[blocks (listof block?)])]
[element ([style element-style?]
[content content?])]
[(toc-element element) ([toc-content content?])]
[(target-element element) ([tag tag?])]
[(toc-target-element target-element) ()]
[(page-target-element target-element) ()]
[(redirect-target-element target-element) ([alt-path path-string?]
[alt-anchor string?])]
[(link-element element) ([tag tag?])]
[(index-element element) ([tag tag?]
[plain-seq (and/c pair? (listof string-without-newline?))]
[entry-seq (listof content?)]
[desc any/c])]
[(image-element element) ([path (or/c path-string?
(cons/c (one-of/c 'collects)
(listof bytes?)))]
[suffixes (listof #rx"^[.]")]
[scale real?])]
[multiarg-element ([style element-style?]
[contents (listof content?)])]
[style ([name (or/c string? symbol? #f)]
[variants list?])]
;; variants:
[document-version ([text (or/c string? false/c)])]
[target-url ([addr path-string?])]
[color-variant ([color (or/c string? (list/c byte? byte? byte?))])]
[background-color-variant ([color (or/c string? (list/c byte? byte? byte?))])]
[table-columns ([styles (listof style?)])]
[table-cells ([styless (listof (listof style?))])]
[collected-info ([number (listof (or/c false/c integer?))]
[parent (or/c false/c part?)]
[info any/c])])
(provide plain)
(define plain (make-style #f null))
;; ----------------------------------------
;; Delayed element has special serialization support:
(define-struct delayed-element (resolve sizer plain)
#:property
prop:serializable
(make-serialize-info
(lambda (d)
(let ([ri (current-serialize-resolve-info)])
(unless ri
(error 'serialize-delayed-element
"current-serialize-resolve-info not set"))
(with-handlers ([exn:fail:contract?
(lambda (exn)
(error 'serialize-delayed-element
"serialization failed (wrong resolve info? delayed element never rendered?); ~a"
(exn-message exn)))])
(vector
(let ([l (delayed-element-content d ri)])
l)))))
#'deserialize-delayed-element
#f
(or (current-load-relative-directory) (current-directory))))
(provide/contract
(struct delayed-element ([resolve (any/c part? resolve-info? . -> . list?)]
[sizer (-> any)]
[plain (-> any)])))
(provide deserialize-delayed-element)
(define deserialize-delayed-element
(make-deserialize-info values values))
(provide delayed-element-content)
(define (delayed-element-content e ri)
(hash-ref (resolve-info-delays ri) e))
(provide delayed-block-blocks)
(define (delayed-block-blocks p ri)
(hash-ref (resolve-info-delays ri) p))
(provide current-serialize-resolve-info)
(define current-serialize-resolve-info (make-parameter #f))
;; ----------------------------------------
;; part-relative element has special serialization support:
(define-struct part-relative-element (collect sizer plain)
#:property
prop:serializable
(make-serialize-info
(lambda (d)
(let ([ri (current-serialize-resolve-info)])
(unless ri
(error 'serialize-part-relative-element
"current-serialize-resolve-info not set"))
(with-handlers ([exn:fail:contract?
(lambda (exn)
(error 'serialize-part-relative-element
"serialization failed (wrong resolve info? part-relative element never rendered?); ~a"
(exn-message exn)))])
(vector
(part-relative-element-content d ri)))))
#'deserialize-part-relative-element
#f
(or (current-load-relative-directory) (current-directory))))
(provide/contract
(struct part-relative-element ([collect (collect-info? . -> . list?)]
[sizer (-> any)]
[plain (-> any)])))
(provide deserialize-part-relative-element)
(define deserialize-part-relative-element
(make-deserialize-info values values))
(provide part-relative-element-content)
(define (part-relative-element-content e ci/ri)
(hash-ref (collect-info-relatives
(if (resolve-info? ci/ri) (resolve-info-ci ci/ri) ci/ri))
e))
(provide collect-info-parents)
;; ----------------------------------------
;; Delayed index entry also has special serialization support.
;; It uses the same delay -> value table as delayed-element
(define-struct delayed-index-desc (resolve)
#:mutable
#:property
prop:serializable
(make-serialize-info
(lambda (d)
(let ([ri (current-serialize-resolve-info)])
(unless ri
(error 'serialize-delayed-index-desc
"current-serialize-resolve-info not set"))
(with-handlers ([exn:fail:contract?
(lambda (exn)
(error 'serialize-index-desc
"serialization failed (wrong resolve info?); ~a"
(exn-message exn)))])
(vector
(delayed-element-content d ri)))))
#'deserialize-delayed-index-desc
#f
(or (current-load-relative-directory) (current-directory))))
(provide/contract
(struct delayed-index-desc ([resolve (any/c part? resolve-info? . -> . any)])))
(provide deserialize-delayed-index-desc)
(define deserialize-delayed-index-desc
(make-deserialize-info values values))
;; ----------------------------------------
(define-struct (collect-element element) (collect)
#:mutable
#:property
prop:serializable
(make-serialize-info
(lambda (d)
(vector (make-element
(element-style d)
(element-content 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 element-style?]
[content content?]
[collect (collect-info? . -> . any)])])
;; ----------------------------------------
(define-struct (render-element element) (render)
#:property
prop:serializable
(make-serialize-info
(lambda (d)
(vector (make-element
(element-style d)
(element-content d))))
#'deserialize-render-element
#f
(or (current-load-relative-directory) (current-directory))))
(provide deserialize-render-element)
(define deserialize-render-element
(make-deserialize-info values values))
(provide/contract
[struct render-element ([style element-style?]
[content content?]
[render (any/c part? resolve-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-ref (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-out generated-tag))
(provide deserialize-generated-tag)
(define deserialize-generated-tag
(make-deserialize-info values values))
(provide generate-tag tag-key
current-tag-prefixes
add-current-tag-prefix)
(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-ref tags t #f)
(let ([key (list* 'gentag
(hash-count tags)
(collect-info-gen-prefix ci))])
(hash-set! tags t key)
key)))))
tg))
(define (tag-key tg ri)
(if (generated-tag? (cadr tg))
(list (car tg)
(hash-ref (collect-info-tags (resolve-info-ci ri)) (cadr tg)))
tg))
(define current-tag-prefixes (make-parameter null))
(define (add-current-tag-prefix t)
(let ([l (current-tag-prefixes)])
(if (null? l)
t
(cons (car t) (append l (cdr t))))))
;; ----------------------------------------
(provide content->string
strip-aux)
(define content->string
(case-lambda
[(c)
(cond
[(element? c) (content->string (element-content c))]
[(multiarg-element? c) (content->string (multiarg-element-contents c))]
[(list? c) (apply string-append (map content->string c))]
[(part-relative-element? c) (content->string ((part-relative-element-plain c)))]
[(delayed-element? c) (content->string ((delayed-element-plain c)))]
[(string? c) c]
[else (case c
[(mdash) "---"]
[(ndash) "--"]
[(ldquo rdquo) "\""]
[(rsquo) "'"]
[(rarr) "->"]
[(lang) "<"]
[(rang) ">"]
[else (format "~s" c)])])]
[(c renderer sec ri)
(cond
[(and (link-element? c)
(null? (element-content c)))
(let ([dest (resolve-get sec ri (link-element-tag c))])
;; FIXME: this is specific to renderer
(if dest
(content->string (strip-aux
(if (pair? dest) (cadr dest) (vector-ref dest 1)))
renderer sec ri)
"???"))]
[(element? c) (content->string (element-content c) renderer sec ri)]
[(multiarg-element? c) (content->string (multiarg-element-contents c) renderer sec ri)]
[(list? c) (apply string-append
(map(lambda (e) (content->string e renderer sec ri))
c))]
[(delayed-element? c)
(content->string (delayed-element-content c ri) renderer sec ri)]
[(part-relative-element? c)
(content->string (part-relative-element-content c ri) renderer sec ri)]
[else (content->string c)])]))
(define (aux-element? e)
(and (element? e)
(let ([s (element-style e)])
(and (style? e)
(memq 'aux (style-variants s))))))
(define (strip-aux content)
(cond
[(null? content) null]
[(aux-element? content) null]
[(list? content) (map strip-aux content)]
[else content]))
;; ----------------------------------------
(provide block-width
content-width)
(define (content-width s)
(cond
[(string? s) (string-length s)]
[(list? s) (for/fold ([v 0]) ([s (in-list s)]) (+ v (content-width s)))]
[(element? s) (content-width (element-content s))]
[(multiarg-element? s) (content-width (multiarg-element-contents s))]
[(delayed-element? s) (content-width ((delayed-element-sizer s)))]
[(part-relative-element? s) (content-width ((part-relative-element-sizer s)))]
[else 1]))
(define (paragraph-width s)
(content-width (paragraph-content s)))
(define (flow-width f)
(apply max 0 (map block-width f)))
(define (block-width p)
(cond
[(paragraph? p) (paragraph-width p)]
[(table? p) (table-width p)]
[(itemization? p) (itemization-width p)]
[(nested-flow? p) (nested-flow-width p)]
[(compound-paragraph? p) (compound-paragraph-width p)]
[(delayed-block? p) 1]
[(eq? p 'cont) 0]))
(define (table-width p)
(let ([blocks (table-blockss p)])
(if (null? blocks)
0
(let loop ([blocks blocks])
(if (null? (car blocks))
0
(+ (apply max 0 (map block-width (map car blocks)))
(loop (map cdr blocks))))))))
(define (itemization-width p)
(apply max 0 (map flow-width (itemization-blockss p))))
(define (nested-flow-width p)
(+ 4 (apply max 0 (map block-width (nested-flow-blocks p)))))
(define (compound-paragraph-width p)
(apply max 0 (map block-width (compound-paragraph-blocks p))))
;; ----------------------------------------
(define (info-key? l)
(and (pair? l)
(symbol? (car l))
(pair? (cdr l))))
(provide info-key?)
(provide/contract
[part-collected-info (part? resolve-info? . -> . collected-info?)]
[collect-put! (collect-info? info-key? any/c . -> . any)]
[resolve-get ((or/c part? false/c) resolve-info? info-key? . -> . any)]
[resolve-get/tentative ((or/c part? false/c) resolve-info? info-key? . -> . any)]
[resolve-get/ext? ((or/c part? false/c) resolve-info? info-key? . -> . any)]
[resolve-search (any/c (or/c part? false/c) resolve-info? info-key? . -> . any)]
[resolve-get-keys ((or/c part? false/c) resolve-info? (info-key? . -> . any/c) . -> . any/c)])

3
collects/scribble/decode-struct.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require "struct.ss") (require "core.ss"
"private/provide-structs.ss")
(provide-structs (provide-structs
[part-index-desc ()]) [part-index-desc ()])

103
collects/scribble/decode.ss
View File

@ -1,5 +1,6 @@
#lang scheme/base #lang scheme/base
(require "struct.ss" (require "core.ss"
"private/provide-structs.ss"
"decode-struct.ss" "decode-struct.ss"
scheme/contract scheme/contract
scheme/class scheme/class
@ -14,19 +15,36 @@
(rename-out [decode-content decode-elements]) (rename-out [decode-content decode-elements])
decode-string decode-string
whitespace? whitespace?
clean-up-index-string) clean-up-index-string
pre-content?
pre-flow?)
(define (pre-content? i)
(or (string? i)
(and (content? i)
(not (list? i)))
(and (splice? i)
(andmap pre-content? (splice-run i)))))
(define (pre-flow? i)
(or (string? i)
(and (content? i)
(not (list? i)))
(block? i)
(and (splice? i)
(andmap pre-flow? (splice-run i)))))
(provide-structs (provide-structs
[title-decl ([tag-prefix (or/c false/c string?)] [title-decl ([tag-prefix (or/c false/c string?)]
[tags (listof tag?)] [tags (listof tag?)]
[version (or/c string? false/c)] [version (or/c string? false/c)]
[style any/c] [style style?]
[content list?])] [content content?])]
[part-start ([depth integer?] [part-start ([depth integer?]
[tag-prefix (or/c false/c string?)] [tag-prefix (or/c false/c string?)]
[tags (listof tag?)] [tags (listof tag?)]
[style any/c] [style style?]
[title list?])] [title content?])]
[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?])]
@ -67,11 +85,6 @@
null null
(list (decode-compound-paragraph (reverse (skip-whitespace accum)))))) (list (decode-compound-paragraph (reverse (skip-whitespace accum))))))
(define (part-version p)
(if (versioned-part? p)
(versioned-part-version p)
#f))
(define (decode-flow* l keys colls tag-prefix tags vers style title part-depth) (define (decode-flow* l keys colls tag-prefix tags vers style title part-depth)
(let loop ([l l] [next? #f] [keys keys] [colls colls] [accum null] (let loop ([l l] [next? #f] [keys keys] [colls colls] [accum null]
[title title] [tag-prefix tag-prefix] [tags tags] [vers vers] [title title] [tag-prefix tag-prefix] [tags tags] [vers vers]
@ -82,11 +95,15 @@
[tags (if (null? tags) [tags (if (null? tags)
(list `(part ,(make-generated-tag))) (list `(part ,(make-generated-tag)))
tags)]) tags)])
(make-versioned-part (make-part
tag-prefix tag-prefix
(append tags k-tags) (append tags k-tags)
title title
style (if vers
(make-style (style-name style)
(cons (make-document-version vers)
(style-variants style)))
style)
(let ([l (append (let ([l (append
(map (lambda (k tag) (map (lambda (k tag)
(make-index-element #f null tag (make-index-element #f null tag
@ -95,8 +112,8 @@
#f)) #f))
keys k-tags) keys k-tags)
colls)]) colls)])
(if (and title (not (or (eq? 'hidden style) (if (and title
(and (list? style) (memq 'hidden style))))) (not (memq 'hidden (style-variants style))))
(cons (make-index-element (cons (make-index-element
#f null (car tags) #f null (car tags)
(list (clean-up-index-string (list (clean-up-index-string
@ -106,9 +123,8 @@
(make-part-index-desc)) (make-part-index-desc))
l) l)
l)) l))
(make-flow (decode-accum-para accum)) (decode-accum-para accum)
null null))]
vers))]
[(title-decl? (car l)) [(title-decl? (car l))
(cond [(not part-depth) (error 'decode "misplaced title: ~e" (car l))] (cond [(not part-depth) (error 'decode "misplaced title: ~e" (car l))]
[title (error 'decode "found extra title: ~v" (car l))] [title (error 'decode "found extra title: ~v" (car l))]
@ -124,29 +140,26 @@
(let ([para (decode-accum-para accum)] (let ([para (decode-accum-para accum)]
[part (decode-flow* (cdr l) keys colls tag-prefix tags vers style [part (decode-flow* (cdr l) keys colls tag-prefix tags vers style
title part-depth)]) title part-depth)])
(make-versioned-part (make-part
(part-tag-prefix part) (part-tag-prefix part)
(part-tags part) (part-tags part)
(part-title-content part) (part-title-content part)
(part-style part) (part-style part)
(part-to-collect part) (part-to-collect part)
(make-flow (append para (list (car l)) (append para (list (car l)) (part-flow part))
(flow-paragraphs (part-flow part)))) (part-parts part)))]
(part-parts part)
(part-version 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 colls tag-prefix tags vers style [part (decode-flow* (cdr l) keys colls tag-prefix tags vers style
title part-depth)]) title part-depth)])
(make-versioned-part (make-part
(part-tag-prefix part) (part-tag-prefix part)
(part-tags part) (part-tags part)
(part-title-content part) (part-title-content part)
(part-style part) (part-style part)
(part-to-collect part) (part-to-collect part)
(make-flow (append para (flow-paragraphs (part-flow part)))) (append para (part-blocks part))
(cons (car l) (part-parts part)) (cons (car l) (part-parts part))))]
(part-version 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)))
@ -166,14 +179,13 @@
(add1 part-depth))] (add1 part-depth))]
[part (decode-flow* l keys colls tag-prefix tags vers style [part (decode-flow* l keys colls tag-prefix tags vers style
title part-depth)]) title part-depth)])
(make-versioned-part (part-tag-prefix part) (make-part (part-tag-prefix part)
(part-tags part) (part-tags part)
(part-title-content part) (part-title-content part)
(part-style part) (part-style part)
(part-to-collect part) (part-to-collect part)
(make-flow para) para
(cons s (part-parts part)) (cons s (part-parts part))))
(part-version 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))))))]
@ -205,29 +217,28 @@
(if m (if m
(let ([part (loop m #t keys colls null title tag-prefix tags vers (let ([part (loop m #t keys colls null title tag-prefix tags vers
style)]) style)])
(make-versioned-part (make-part
(part-tag-prefix part) (part-tag-prefix part)
(part-tags part) (part-tags part)
(part-title-content part) (part-title-content part)
(part-style part) (part-style part)
(part-to-collect part) (part-to-collect part)
(make-flow (append (decode-accum-para accum) (append (decode-accum-para accum)
(flow-paragraphs (part-flow part)))) (part-blocks part))
(part-parts part) (part-parts part)))
(part-version part)))
(loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix
tags vers style))))] tags vers style))))]
[else (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix [else (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix
tags vers style)]))) tags vers style)])))
(define (decode-part l tags title depth) (define (decode-part l tags title depth)
(decode-flow* l null null #f tags #f #f title depth)) (decode-flow* l null null #f tags #f plain title depth))
(define (decode-styled-part l tag-prefix tags style title depth) (define (decode-styled-part l tag-prefix tags style title depth)
(decode-flow* l null null tag-prefix tags #f style title depth)) (decode-flow* l null null tag-prefix tags #f style title depth))
(define (decode-flow l) (define (decode-flow l)
(part-flow (decode-flow* l null null #f null #f #f #f #f))) (part-blocks (decode-flow* l null null #f null #f plain #f #f)))
(define (match-newline-whitespace l) (define (match-newline-whitespace l)
(cond [(null? l) #f] (cond [(null? l) #f]
@ -246,7 +257,7 @@
(decode-part l null #f 0)) (decode-part l null #f 0))
(define (decode-paragraph l) (define (decode-paragraph l)
(make-paragraph (decode-content l))) (make-paragraph plain (decode-content l)))
(define (decode-content l) (define (decode-content l)
(append-map (lambda (s) (if (string? s) (decode-string s) (list s))) (append-map (lambda (s) (if (string? s) (decode-string s) (list s)))
@ -256,7 +267,7 @@
(define (finish-accum para-accum) (define (finish-accum para-accum)
(if (null? para-accum) (if (null? para-accum)
null null
(list (make-paragraph (skip-whitespace (apply append (reverse para-accum))))))) (list (make-paragraph plain (skip-whitespace (apply append (reverse para-accum)))))))
(let ([r (let loop ([l (skip-whitespace l)] (let ([r (let loop ([l (skip-whitespace l)]
[para-accum null]) [para-accum null])
(cond (cond
@ -274,7 +285,7 @@
(cons (list (car l)) para-accum))]))]))]) (cons (list (car l)) para-accum))]))]))])
(cond (cond
[(null? r) [(null? r)
(make-paragraph null)] (make-paragraph plain null)]
[(null? (cdr r)) [(null? (cdr r))
(car r)] (car r)]
[(make-compound-paragraph #f r)]))) [(make-compound-paragraph plain r)])))

2
collects/scribble/doc/reader.ss
View File

@ -5,6 +5,6 @@ scribble/doclang
#:read scribble:read-inside #:read scribble:read-inside
#:read-syntax scribble:read-syntax-inside #:read-syntax scribble:read-syntax-inside
#:whole-body-readers? #t #:whole-body-readers? #t
#:wrapper1 (lambda (t) (list* 'doc '() (t))) #:wrapper1 (lambda (t) (list* 'doc 'values '() (t)))
(require (prefix-in scribble: "../reader.ss")) (require (prefix-in scribble: "../reader.ss"))

18
collects/scribble/doclang.ss
View File

@ -12,17 +12,17 @@
(define-syntax (*module-begin stx) (define-syntax (*module-begin stx)
(syntax-case stx () (syntax-case stx ()
[(_ id exprs . body) [(_ id post-process exprs . body)
#'(#%module-begin #'(#%module-begin
(doc-begin id exprs . body))])) (doc-begin id post-process exprs . body))]))
(define-syntax (doc-begin stx) (define-syntax (doc-begin stx)
(syntax-case stx () (syntax-case stx ()
[(_ m-id (expr ...)) [(_ m-id post-process (expr ...))
#`(begin #`(begin
(define m-id (decode (list . #,(reverse (syntax->list #'(expr ...)))))) (define m-id (post-process (decode (list . #,(reverse (syntax->list #'(expr ...)))))))
(provide m-id))] (provide m-id))]
[(_ m-id exprs . body) [(_ m-id post-process exprs . body)
;; `body' probably starts with lots of string constants; it's ;; `body' probably starts with lots of string constants; it's
;; slow to trampoline on every string, so do them in a batch ;; slow to trampoline on every string, so do them in a batch
;; here: ;; here:
@ -34,7 +34,7 @@
(loop #'rest (cons #'s accum))] (loop #'rest (cons #'s accum))]
[() [()
(with-syntax ([(accum ...) accum]) (with-syntax ([(accum ...) accum])
#`(doc-begin m-id (accum ... . exprs)))] #`(doc-begin m-id post-process (accum ... . exprs)))]
[(body1 . body) [(body1 . body)
(with-syntax ([exprs (append accum #'exprs)]) (with-syntax ([exprs (append accum #'exprs)])
(let ([expanded (local-expand (let ([expanded (local-expand
@ -46,7 +46,7 @@
#%require))))]) #%require))))])
(syntax-case expanded (begin) (syntax-case expanded (begin)
[(begin body1 ...) [(begin body1 ...)
#`(doc-begin m-id exprs body1 ... . body)] #`(doc-begin m-id post-process exprs body1 ... . body)]
[(id . rest) [(id . rest)
(and (identifier? #'id) (and (identifier? #'id)
(ormap (lambda (kw) (free-identifier=? #'id kw)) (ormap (lambda (kw) (free-identifier=? #'id kw))
@ -57,6 +57,6 @@
define-values-for-syntax define-values-for-syntax
#%require #%require
#%provide)))) #%provide))))
#`(begin #,expanded (doc-begin m-id exprs . body))] #`(begin #,expanded (doc-begin m-id post-process exprs . body))]
[_else [_else
#`(doc-begin m-id (#,expanded . exprs) . body)])))]))])) #`(doc-begin m-id post-process (#,expanded . exprs) . body)])))]))]))

14
collects/scribble/eval.ss
View File

@ -90,13 +90,13 @@
(if (flow? p) (if (flow? p)
p p
(make-flow (list p)))))) (make-flow (list p))))))
(format-output (cadar val-list+outputs) "schemestdout") (format-output (cadar val-list+outputs) output-color)
(format-output (caddar val-list+outputs) "schemeerror") (format-output (caddar val-list+outputs) error-color)
(if (string? (caar val-list+outputs)) (if (string? (caar val-list+outputs))
;; Error result case: ;; Error result case:
(map (map
(lambda (s) (lambda (s)
(car (format-output s "schemeerror"))) (car (format-output s error-color)))
(let sloop ([s (caar val-list+outputs)]) (let sloop ([s (caar val-list+outputs)])
(if ((string-length s) . > . maxlen) (if ((string-length s) . > . maxlen)
;; break the error message into multiple lines: ;; break the error message into multiple lines:
@ -117,8 +117,8 @@
(list (make-flow (list (make-paragraph (list (make-flow (list (make-paragraph
(list (list
(hspace 2) (hspace 2)
(span-class "schemeresult" (elem #:style result-color
(to-element/no-color v)))))))) (to-element/no-color v))))))))
val-list)))) val-list))))
(loop (cdr expr-paras) (loop (cdr expr-paras)
(cdr val-list+outputs) (cdr val-list+outputs)
@ -313,8 +313,8 @@
(define (show-val v) (define (show-val v)
(span-class "schemeresult" (elem #:style result-color
(to-element/no-color v))) (to-element/no-color v)))
(define (do-interaction-eval-show ev e) (define (do-interaction-eval-show ev e)
(parameterize ([current-command-line-arguments #()]) (parameterize ([current-command-line-arguments #()])

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

File diff suppressed because it is too large Load Diff

16
collects/scribble/html-variants.ss Normal file
View File

@ -0,0 +1,16 @@
#lang scheme/base
(require "private/provide-structs.ss"
scheme/contract)
(provide-structs
[body-id ([value string?])]
[hover-variant ([text string?])]
[script-variant ([type string?]
[script (or/c path-string? (listof string?))])]
[css-addition ([path (or/c path-string? (cons/c 'collects (listof bytes?)))])]
[html-defaults ([prefix-path (or/c bytes? path-string? (cons/c 'collects (listof bytes?)))]
[style-path (or/c bytes? path-string? (cons/c 'collects (listof bytes?)))]
[extra-files (listof (or/c path-string? (cons/c 'collects (listof bytes?))))])]
[url-anchor ([name string?])]
[attributes ([assoc (listof (cons/c symbol? string?))])])

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

@ -1,6 +1,8 @@
#lang scheme/base #lang scheme/base
(require "struct.ss" (require "core.ss"
"latex-variants.ss"
"private/render-utils.ss"
scheme/class scheme/class
scheme/runtime-path scheme/runtime-path
scheme/port scheme/port
@ -20,11 +22,15 @@
(define-runtime-path scribble-prefix-tex "scribble-prefix.tex") (define-runtime-path scribble-prefix-tex "scribble-prefix.tex")
(define-runtime-path scribble-tex "scribble.tex") (define-runtime-path scribble-tex "scribble.tex")
(define-runtime-path scribble-style-tex "scribble-style.tex")
(define (gif-to-png p) (define (color->string c)
(if (equal? (filename-extension p) #"gif") (if (string? c)
(path-replace-suffix p #".png") c
p)) (format "~a,~a,~a"
(/ (car c) 255.0)
(/ (cadr c) 255.0)
(/ (caddr c) 255.0))))
(define (render-mixin %) (define (render-mixin %)
(class % (class %
@ -33,48 +39,76 @@
(define/override (get-suffix) #".tex") (define/override (get-suffix) #".tex")
(inherit render-block (inherit render-block
render-content
render-part render-part
install-file install-file
format-number format-number
extract-part-style-files) extract-part-style-files
extract-version
extract-authors
extract-pretitle)
(define/override (auto-extra-files? v) (latex-defaults? v))
(define/override (auto-extra-files-paths v) (latex-defaults-extra-files v))
(define/override (render-one d ri fn) (define/override (render-one d ri fn)
(let ([style-file (or style-file scribble-tex)] (let* ([defaults (ormap (lambda (v) (and (latex-defaults? v) v))
[prefix-file (or prefix-file scribble-prefix-tex)]) (style-variants (part-style d)))]
[prefix-file (or prefix-file
(and defaults
(let ([v (latex-defaults-prefix defaults)])
(cond
[(bytes? v) v]
[else (main-collects-relative->path v)])))
scribble-prefix-tex)]
[style-file (or style-file
(and defaults
(let ([v (latex-defaults-style defaults)])
(cond
[(bytes? v) v]
[else (main-collects-relative->path v)])))
scribble-style-tex)])
(for-each (for-each
(lambda (style-file) (lambda (style-file)
(with-input-from-file style-file (if (bytes? style-file)
(lambda () (display style-file)
(copy-port (current-input-port) (current-output-port))))) (with-input-from-file style-file
(list* prefix-file style-file (lambda ()
(append style-extra-files (copy-port (current-input-port) (current-output-port))))))
(extract-part-style-files (list* prefix-file
scribble-tex
(append (extract-part-style-files
d d
ri ri
'tex 'tex
(lambda (p) #f))))) (lambda (p) #f)
tex-addition?
tex-addition-path)
(list style-file)
style-extra-files)))
(printf "\\begin{document}\n\\preDoc\n") (printf "\\begin{document}\n\\preDoc\n")
(when (part-title-content d) (when (part-title-content d)
(let ([m (ormap (lambda (v) (let ([vers (extract-version d)]
(and (styled-paragraph? v) [pres (extract-pretitle d)]
(equal? "author" (styled-paragraph-style v)) [auths (extract-authors d)])
v)) (for ([pre (in-list pres)])
(flow-paragraphs (part-flow d)))]) (do-render-paragraph pre d ri #t))
(when m (printf "\\titleAnd~aVersionAnd~aAuthors{"
(do-render-paragraph m d ri #t))) (if (equal? vers "") "Empty" "")
(let ([vers (or (and (versioned-part? d) (versioned-part-version d)) (if (null? auths) "Empty" ""))
(version))])
(printf "\\titleAnd~aVersion{" (if (equal? vers "") "Empty" ""))
(render-content (part-title-content d) d ri) (render-content (part-title-content d) d ri)
(printf "}{~a}\n" vers))) (printf "}{~a}{" vers)
(for/fold ([first? #t]) ([auth (in-list auths)])
(unless first? (printf "\\SAuthorSep{}"))
(do-render-paragraph auth d ri #t)
#f)
(printf "}\n")))
(render-part d ri) (render-part d ri)
(printf "\n\n\\postDoc\n\\end{document}\n"))) (printf "\n\n\\postDoc\n\\end{document}\n")))
(define/override (render-part-content d ri) (define/override (render-part-content d ri)
(let ([number (collected-info-number (part-collected-info d ri))]) (let ([number (collected-info-number (part-collected-info d ri))])
(when (and (part-title-content d) (pair? number)) (when (and (part-title-content d) (pair? number))
(when (part-style? d 'index) (when (eq? (style-name (part-style d)) 'index)
(printf "\\twocolumn\n\\parskip=0pt\n\\addcontentsline{toc}{section}{Index}\n")) (printf "\\twocolumn\n\\parskip=0pt\n\\addcontentsline{toc}{section}{Index}\n"))
(let ([no-number? (and (pair? number) (let ([no-number? (and (pair? number)
(or (not (car number)) (or (not (car number))
@ -96,38 +130,32 @@
(printf "{") (printf "{")
(render-content (part-title-content d) d ri) (render-content (part-title-content d) d ri)
(printf "}") (printf "}")
(when (part-style? d 'index) (printf "\n\n"))) (when (eq? (style-name (part-style d)) 'index) (printf "\n\n")))
(for ([t (part-tags d)]) (for ([t (part-tags d)])
(printf "\\label{t:~a}\n\n" (t-encode (add-current-tag-prefix (tag-key t ri))))) (printf "\\label{t:~a}\n\n" (t-encode (add-current-tag-prefix (tag-key t ri)))))
(render-flow (part-flow d) d ri #f) (render-flow (part-blocks d) d ri #f)
(for ([sec (part-parts d)]) (render-part sec ri)) (for ([sec (part-parts d)]) (render-part sec ri))
(when (part-style? d 'index) (printf "\\onecolumn\n\n")) (when (eq? (style-name (part-style d)) 'index) (printf "\\onecolumn\n\n"))
null)) null))
(define/override (render-paragraph p part ri) (define/override (render-paragraph p part ri)
(do-render-paragraph p part ri #f)) (do-render-paragraph p part ri #f))
(define/private (do-render-paragraph p part ri author?) (define/private (do-render-paragraph p part ri show-pre?)
(let ([style (and (styled-paragraph? p) (let* ([sn (style-name (paragraph-style p))]
(let ([s (flatten-style [style (if (eq? sn 'author)
(styled-paragraph-style p))]) "SAuthor"
(if (with-attributes? s) sn)])
(let ([base (with-attributes-style s)]) (unless (and (not show-pre?)
(if (eq? base 'div) (or (eq? sn 'author)
(let ([a (assq 'class (with-attributes-assoc s))]) (eq? sn 'pretitle)))
(if a (let ([use-style? (string? style)])
(cdr a) (when use-style?
base)) (printf "\\~a{" style))
base)) (if (toc-paragraph? p)
s)))]) (printf "\\newpage \\tableofcontents \\newpage")
(unless (and (not author?) (super render-paragraph p part ri))
(equal? style "author")) (when use-style? (printf "}")))))
(when (string? style)
(printf "\\~a{" style))
(if (toc-paragraph? p)
(printf "\\newpage \\tableofcontents \\newpage")
(super render-paragraph p part ri))
(when (string? style) (printf "}"))))
null) null)
(define/override (render-intrapara-block p part ri first? last? starting-item?) (define/override (render-intrapara-block p part ri first? last? starting-item?)
@ -136,91 +164,131 @@
(begin0 (begin0
(super render-intrapara-block p part ri first? last? starting-item?))) (super render-intrapara-block p part ri first? last? starting-item?)))
(define/override (render-element e part ri) (define/override (render-content e part ri)
(when (render-element? e) (when (render-element? e)
((render-element-render e) this part ri)) ((render-element-render e) this 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)))]) (empty-content? (element-content e)))])
(parameterize ([done-link-page-numbers (or (done-link-page-numbers) (parameterize ([done-link-page-numbers (or (done-link-page-numbers)
(link-element? e))]) (link-element? e))])
(when (target-element? e) (when (target-element? e)
(printf "\\label{t:~a}" (printf "\\label{t:~a}"
(t-encode (add-current-tag-prefix (tag-key (target-element-tag e) ri))))) (t-encode (add-current-tag-prefix (tag-key (target-element-tag e) ri)))))
(when part-label? (when part-label?
(printf "\\SecRef{") (let ([dest (resolve-get part ri (link-element-tag e))])
(render-content (printf "\\~aRef~a{"
(let ([dest (resolve-get part ri (link-element-tag e))]) (case (and dest (length (cadr dest)))
[(0) "Book"]
[(1) "Chap"]
[else "Sec"])
(if (let ([s (element-style e)])
(and (style? s) (memq 'uppercase (style-variants s))))
"UC"
""))
(render-content
(if dest (if dest
(if (list? (cadr dest)) (if (list? (cadr dest))
(format-number (cadr dest) null) (format-number (cadr dest) null)
(begin (fprintf (current-error-port) (begin (fprintf (current-error-port)
"Internal tag error: ~s -> ~s\n" "Internal tag error: ~s -> ~s\n"
(link-element-tag e) (link-element-tag e)
dest) dest)
'("!!!"))) '("!!!")))
(list "???"))) (list "???"))
part ri) part ri)
(printf "}{")) (printf "}{")))
(let ([style (and (element? e) (let* ([es (cond
(let ([s (flatten-style (element-style e))]) [(element? e) (element-style e)]
(if (with-attributes? s) [(multiarg-element? e) (multiarg-element-style e)]
(with-attributes-style s) [else #f])]
s)))] [style-name (if (style? es)
[wrap (lambda (e s tt?) (style-name es)
(printf "\\~a{" s) es)]
(parameterize ([rendering-tt (or tt? (rendering-tt))]) [style (and (style? es) es)]
(super render-element e part ri)) [core-render (lambda (e tt?)
(printf "}"))]) (if (and (image-element? e)
(cond (not (disable-images)))
[(symbol? style) (let ([fn (install-file
(case style (select-suffix
[(italic) (wrap e "textit" #f)] (main-collects-relative->path
[(bold) (wrap e "textbf" #f)] (image-element-path e))
[(tt) (wrap e "Scribtexttt" #t)] (image-element-suffixes e)
[(url) (wrap e "nolinkurl" 'exact)] '(".pdf" ".ps" ".png")))])
[(no-break) (super render-element e part ri)] (printf "\\includegraphics[scale=~a]{~a}"
[(sf) (wrap e "textsf" #f)] (image-element-scale e) fn))
[(subscript) (wrap e "textsub" #f)] (parameterize ([rendering-tt (or tt? (rendering-tt))])
[(superscript) (wrap e "textsuper" #f)] (super render-content e part ri))))]
[(hspace) [wrap (lambda (e s tt?)
(let ([s (content->string (element-content e))]) (printf "\\~a{" s)
(case (string-length s) (core-render e tt?)
[(0) (void)] (printf "}"))])
[else (define (finish tt?)
(printf "\\mbox{\\hphantom{\\Scribtexttt{~a}}}" (cond
(regexp-replace* #rx"." s "x"))]))] [(symbol? style-name)
[(newline) (printf "\\\\")] (case style-name
[else (error 'latex-render [(italic) (wrap e "textit" tt?)]
"unrecognzied style symbol: ~s" style)])] [(bold) (wrap e "textbf" tt?)]
[(target-url? style) [(tt) (wrap e "Scribtexttt" #t)]
(wrap e (format "href{~a}" (target-url-addr style)) #f)] [(url) (wrap e "nolinkurl" 'exact)]
[(string? style) [(no-break) (core-render e tt?)]
(wrap e style (regexp-match? #px"^scheme(?!error)" style))] [(sf) (wrap e "textsf" #f)]
[(and (pair? style) (memq (car style) '(bg-color color))) [(subscript) (wrap e "textsub" #f)]
(wrap e (format [(superscript) (wrap e "textsuper" #f)]
"~a{~a}" [(smaller) (wrap e "Smaller" #f)]
(format (if (eq? (car style) 'bg-color) [(larger) (wrap e "Larger" #f)]
"in~acolorbox" "intext~acolor") [(hspace)
(if (= (length style) 2) "" "rgb")) (let ([s (content->string e)])
(if (= (length style) 2) (case (string-length s)
(cadr style) [(0) (void)]
(format "~a,~a,~a" [else
(/ (cadr style) 255.0) (printf "\\mbox{\\hphantom{\\Scribtexttt{~a}}}"
(/ (caddr style) 255.0) (regexp-replace* #rx"." s "x"))]))]
(/ (cadddr style) 255.0)))) [(newline) (printf "\\\\")]
#f)] [else (error 'latex-render
[(image-file? style) "unrecognzied style symbol: ~s" style)])]
(if (disable-images) [(string? style-name)
(void) (let* ([v (if style (style-variants style) null)]
(let ([fn (install-file [tt? (cond
(gif-to-png [(memq 'tt-chars v) #t]
(main-collects-relative->path [(memq 'exact-chars v) 'exact]
(image-file-path style))))]) [else tt?])])
(printf "\\includegraphics[scale=~a]{~a}" (cond
(image-file-scale style) fn)))] [(multiarg-element? e)
[else (super render-element e part ri)]))) (printf "\\~a" style-name)
(if (null? (multiarg-element-contents e))
(printf "{}")
(for ([i (in-list (multiarg-element-contents e))])
(printf "{")
(render-content i part ri)
(printf "}")))]
[else
(wrap e style-name tt?)]))]
[else
(core-render e tt?)]))
(let loop ([l (if style (style-variants style) null)] [tt? #f])
(if (null? l)
(finish tt?)
(let ([v (car l)])
(cond
[(target-url? v)
(printf "\\href{~a}{" (target-url-addr v))
(loop (cdr l) #t)
(printf "}")]
[(color-variant? v)
(printf "\\intext~acolor{~a}{"
(if (string? (color-variant-color v)) "" "rgb")
(color->string (color-variant-color v)))
(loop (cdr l) tt?)
(printf "}")]
[(background-color-variant? v)
(printf "\\in~acolorbox{~a}{"
(if (string? (background-color-variant-color v)) "" "rgb")
(color->string (background-color-variant-color v)))
(loop (cdr l) tt?)
(printf "}")]
[else (loop (cdr l) tt?)]))))))
(when part-label? (when part-label?
(printf "}")) (printf "}"))
(when (and (link-element? e) (when (and (link-element? e)
@ -244,60 +312,70 @@
(string->list (format "~s" s))))) (string->list (format "~s" s)))))
(define/override (render-flow p part ri starting-item?) (define/override (render-flow p part ri starting-item?)
(if (null? (flow-paragraphs p)) (if (null? p)
null null
(begin (begin
(render-block (car (flow-paragraphs p)) part ri starting-item?) (render-block (car p) part ri starting-item?)
(for ([b (in-list (cdr (flow-paragraphs p)))]) (for ([b (in-list (cdr p))])
(printf "\n\n") (printf "\n\n")
(render-block b part ri #f)) (render-block b part ri #f))
null))) null)))
(define/override (render-table t part ri starting-item?) (define/override (render-table t part ri starting-item?)
(let* ([boxed? (eq? 'boxed (table-style t))] (render-table* t part ri starting-item? "[t]"))
[index? (eq? 'index (table-style t))]
(define/private (render-table* t part ri starting-item? alignment)
(let* ([s-name (style-name (table-style t))]
[boxed? (eq? 'boxed s-name)]
[index? (eq? 'index s-name)]
[tableform [tableform
(cond [index? "list"] (cond [index? "list"]
[(not (current-table-mode)) "bigtabular"] [(not (current-table-mode)) "bigtabular"]
[else "tabular"])] [else "tabular"])]
[opt (cond [(equal? tableform "bigtabular") ""] [opt (cond [(equal? tableform "bigtabular") ""]
[(equal? tableform "tabular") "[t]"] [(equal? tableform "tabular") alignment]
[else ""])] [else ""])]
[flowss (if index? (cddr (table-flowss t)) (table-flowss t))] [blockss (if index? (cddr (table-blockss t)) (table-blockss t))]
[row-styles (cdr (or (and (list? (table-style t)) [cell-styless (extract-table-cell-styles t)]
(assoc 'row-styles (table-style t))) [twidth (if (null? (table-blockss t))
(cons #f (map (lambda (x) #f) flowss))))]
[twidth (if (null? (table-flowss t))
1 1
(length (car (table-flowss t))))] (length (car (table-blockss t))))]
[single-column? (and (= 1 twidth) [single-column? (and (= 1 twidth)
(or (not (table-style t)) (or (not s-name) (string? s-name))
(string? (table-style t))) (not (ormap (lambda (cell-styles)
(ormap (lambda (s)
(or (string? (style-name s))
(let ([l (style-variants s)])
(or (memq 'right l)
(memq 'center l)))))
cell-styles))
cell-styless))
(not (current-table-mode)))] (not (current-table-mode)))]
[inline? [inline?
(and (not single-column?) (and (not single-column?)
(not boxed?) (not boxed?)
(not index?) (not index?)
(ormap (lambda (rs) (equal? rs "inferencetop")) row-styles) (ormap (lambda (rs)
(ormap (lambda (cs) (style-name cs)) rs))
cell-styless)
(= 1 twidth) (= 1 twidth)
(let ([m (current-table-mode)]) (let ([m (current-table-mode)])
(and m (and m
(equal? "bigtabular" (car m)) (equal? "bigtabular" (car m))
(= 1 (length (car (table-flowss (cadr m))))))))] (= 1 (length (car (table-blockss (cadr m))))))))]
[boxline "{\\setlength{\\unitlength}{\\linewidth}\\begin{picture}(1,0)\\put(0,0){\\line(1,0){1}}\\end{picture}}"]) [boxline "{\\setlength{\\unitlength}{\\linewidth}\\begin{picture}(1,0)\\put(0,0){\\line(1,0){1}}\\end{picture}}"])
(if single-column? (if single-column?
(begin (begin
(when (string? (table-style t)) (when (string? s-name)
(printf "\\begin{~a}" (table-style t))) (printf "\\begin{~a}" s-name))
(do-render-blockquote (do-render-nested-flow
(make-blockquote "SingleColumn" (make-nested-flow (make-style "SingleColumn" null) (map car (table-blockss t)))
(apply append (map flow-paragraphs (map car (table-flowss t)))))
part part
ri ri
#t) #t)
(when (string? (table-style t)) (when (string? s-name)
(printf "\\end{~a}" (table-style t)))) (printf "\\end{~a}" s-name)))
(unless (or (null? flowss) (null? (car flowss))) (unless (or (null? blockss) (null? (car blockss)))
(parameterize ([current-table-mode (parameterize ([current-table-mode
(if inline? (current-table-mode) (list tableform t))] (if inline? (current-table-mode) (list tableform t))]
[show-link-page-numbers [show-link-page-numbers
@ -311,8 +389,8 @@
(if (and starting-item? (equal? tableform "bigtabular")) (if (and starting-item? (equal? tableform "bigtabular"))
"\\bigtableinlinecorrect" "\\bigtableinlinecorrect"
"") "")
(if (string? (table-style t)) (if (string? s-name)
(format "\\begin{~a}" (table-style t)) (format "\\begin{~a}" s-name)
"") "")
tableform tableform
opt opt
@ -320,36 +398,27 @@
"\\bigtableleftpad" "\\bigtableleftpad"
"") "")
(string-append* (string-append*
(map (lambda (i align) (map (lambda (i cell-style)
(format "~a@{}" (format "~a@{}"
(case align (cond
[(center) "c"] [(memq 'center (style-variants cell-style)) "c"]
[(right) "r"] [(memq 'right (style-variants cell-style)) "r"]
[else "l"]))) [else "l"])))
(car flowss) (car blockss)
(cdr (or (and (list? (table-style t)) (car cell-styless)))
(assoc 'alignment
(or (table-style t) null)))
(cons #f (map (lambda (x) #f)
(car flowss)))))))
(if boxed? (if boxed?
(if (equal? tableform "bigtabular") (if (equal? tableform "bigtabular")
(format "~a \\SEndFirstHead\n" boxline) (format "~a \\SEndFirstHead\n" boxline)
(format "\\multicolumn{~a}{@{}l@{}}{~a} \\\\\n" (format "\\multicolumn{~a}{@{}l@{}}{~a} \\\\\n"
(length (car flowss)) (length (car blockss))
boxline)) boxline))
""))]) ""))])
(let loop ([flowss flowss] (let loop ([blockss blockss]
[row-styles row-styles]) [cell-styless cell-styless])
(let ([flows (car flowss)] (let ([flows (car blockss)]
[row-style (car row-styles)]) [cell-styles (car cell-styless)])
(let loop ([flows flows] (let loop ([flows flows]
[col-v-styles (or (and (list? row-style) [cell-styles cell-styles])
(let ([p (assoc 'valignment row-style)])
(and p (cdr p))))
(let ([p (and (list? (table-style t))
(assoc 'valignment (table-style t)))])
(and p (cdr p))))])
(unless (null? flows) (unless (null? flows)
(when index? (printf "\n\\item ")) (when index? (printf "\n\\item "))
(unless (eq? 'cont (car flows)) (unless (eq? 'cont (car flows))
@ -359,110 +428,103 @@
(loop (cdr flows) (add1 n))] (loop (cdr flows) (add1 n))]
[else n]))]) [else n]))])
(unless (= cnt 1) (printf "\\multicolumn{~a}{l}{" cnt)) (unless (= cnt 1) (printf "\\multicolumn{~a}{l}{" cnt))
(render-table-flow (car flows) part ri twidth (and col-v-styles (render-table-cell (car flows) part ri twidth (car cell-styles))
(car col-v-styles)))
(unless (= cnt 1) (printf "}")) (unless (= cnt 1) (printf "}"))
(unless (null? (list-tail flows cnt)) (printf " &\n")))) (unless (null? (list-tail flows cnt)) (printf " &\n"))))
(unless (null? (cdr flows)) (loop (cdr flows) (unless (null? (cdr flows)) (loop (cdr flows)
(and col-v-styles (cdr col-v-styles)))))) (cdr cell-styles)))))
(unless (or index? (null? (cdr flowss))) (unless (or index? (null? (cdr blockss)))
(printf " \\\\\n") (printf " \\\\\n"))
(when (equal? row-style "inferencetop") (printf "\\hline\n"))) (unless (null? (cdr blockss))
(unless (null? (cdr flowss)) (loop (cdr blockss) (cdr cell-styless)))))
(loop (cdr flowss) (cdr row-styles)))))
(unless inline? (unless inline?
(printf "\\end{~a}~a" (printf "\\end{~a}~a"
tableform tableform
(if (string? (table-style t)) (if (string? s-name)
(format "\\end{~a}" (table-style t)) (format "\\end{~a}" s-name)
""))))))) "")))))))
null) null)
(define/private (render-table-flow p part ri twidth vstyle) (define/private (render-table-cell p part ri twidth vstyle)
;; Emit a \\ between blocks in single-column mode, (let ([top? (memq 'top (style-variants vstyle))]
;; used a nested table otherwise for multiple elements. [center? (memq 'vcenter (style-variants vstyle))])
(let ([in-table? (or (and (not (= twidth 1)) (when (style-name vstyle)
((length (flow-paragraphs p)) . > . 1)) (printf "\\~a{" (style-name vstyle)))
(eq? vstyle 'top))]) (let ([minipage? (and (not (table? p))
(when in-table? (or (not (paragraph? p))
(printf "\\begin{tabular}~a{@{}l@{}}\n" top?
(cond center?))])
[(eq? vstyle 'top) "[t]"]
[(eq? vstyle 'center) "[c]"]
[else ""])))
(let loop ([ps (flow-paragraphs p)])
(cond
[(null? ps) (void)]
[else
(let ([minipage? (or (not (or (paragraph? (car ps))
(table? (car ps))))
(eq? vstyle 'center))])
(when minipage? (when minipage?
(printf "\\begin{minipage}~a{~a\\linewidth}\n" (printf "\\begin{minipage}~a{~a\\linewidth}\n"
(cond (cond
[(eq? vstyle 'top) "[t]"] [top? "[t]"]
[(eq? vstyle 'center) "[c]"] [center? "[c]"]
[else ""]) [else ""])
(/ 1.0 twidth))) (/ 1.0 twidth)))
(render-block (car ps) part ri #f) (if (table? p)
(render-table* p part ri #f (cond
[center? "[c]"]
[else "[t]"]))
(render-block p part ri #f))
(when minipage? (when minipage?
(printf " \\end{minipage}\n")) (printf " \\end{minipage}\n")))
(unless (null? (cdr ps)) (when (style-name vstyle)
(printf " \\\\\n") (printf "}"))
(when in-table?
(printf " ~ \\\\\n"))
(loop (cdr ps))))]))
(when in-table?
(printf "\n\\end{tabular}"))
null)) null))
(define/override (render-itemization t part ri) (define/override (render-itemization t part ri)
(let* ([style-str (and (styled-itemization? t) (let* ([style-str (let ([s (style-name (itemization-style t))])
(string? (styled-itemization-style t)) (if (eq? s 'compact)
(styled-itemization-style t))] "compact"
[mode (or style-str s))]
(if (and (styled-itemization? t) [mode (or (and (string? style-str)
(eq? (styled-itemization-style t) 'ordered)) style-str)
(if (eq? 'ordered style-str)
"enumerate" "enumerate"
"itemize"))]) "itemize"))])
(printf "\\begin{~a}\\atItemizeStart" mode) (printf "\\begin{~a}\\atItemizeStart" mode)
(for ([flow (itemization-flows t)]) (for ([flow (in-list (itemization-blockss t))])
(printf "\n\n\\~a" (if style-str (printf "\n\n\\~a" (if (string? style-str)
(format "~aItem{" style-str) (format "~aItem{" style-str)
"item ")) "item "))
(render-flow flow part ri #t) (render-flow flow part ri #t)
(when style-str (when (string? style-str)
(printf "}"))) (printf "}")))
(printf "\\end{~a}" mode) (printf "\\end{~a}" mode)
null)) null))
(define/private (do-render-blockquote t part ri single-column?) (define/private (do-render-nested-flow t part ri single-column?)
(let ([kind (or (blockquote-style t) "quote")]) (let ([kind (or (let ([s (style-name (nested-flow-style t))])
(if (regexp-match #rx"^[\\]" kind) (or (and (string? s) s)
(printf "~a{" kind) (and (eq? s 'inset) "quote")))
"Subflow")]
[command? (memq 'command (style-variants (nested-flow-style t)))])
(if command?
(printf "\\~a{" kind)
(printf "\\begin{~a}" kind)) (printf "\\begin{~a}" kind))
(parameterize ([current-table-mode (if (or single-column? (parameterize ([current-table-mode (if (or single-column?
(not (current-table-mode))) (not (current-table-mode)))
(current-table-mode) (current-table-mode)
(list "blockquote" t))]) (list "nested-flow" t))])
(render-flow (make-flow (blockquote-paragraphs t)) part ri #f)) (render-flow (nested-flow-blocks t) part ri #f))
(if (regexp-match #rx"^[\\]" kind) (if command?
(printf "}") (printf "}")
(printf "\\end{~a}" kind)) (printf "\\end{~a}" kind))
null)) null))
(define/override (render-blockquote t part ri) (define/override (render-nested-flow t part ri)
(do-render-blockquote t part ri #f)) (do-render-nested-flow t part ri #f))
(define/override (render-compound-paragraph t part ri starting-item?) (define/override (render-compound-paragraph t part ri starting-item?)
(let ([kind (compound-paragraph-style t)]) (let ([kind (style-name (compound-paragraph-style t))]
[command? (memq 'command (style-variants (compound-paragraph-style t)))])
(when kind (when kind
(if (regexp-match #rx"^[\\]" kind) (if command?
(printf "~a{" kind) (printf "\\~a{" kind)
(printf "\\begin{~a}" kind))) (printf "\\begin{~a}" kind)))
(super render-compound-paragraph t part ri starting-item?) (super render-compound-paragraph t part ri starting-item?)
(when kind (when kind
(if (regexp-match #rx"^[\\]" kind) (if command?
(printf "}") (printf "}")
(printf "\\end{~a}" kind))) (printf "\\end{~a}" kind)))
null)) null))
@ -480,6 +542,7 @@
[(rsquo) "'"] [(rsquo) "'"]
[(prime) "$'$"] [(prime) "$'$"]
[(rarr) "$\\rightarrow$"] [(rarr) "$\\rightarrow$"]
[(larr) "$\\leftarrow$"]
[(alpha) "$\\alpha$"] [(alpha) "$\\alpha$"]
[(infin) "$\\infty$"] [(infin) "$\\infty$"]
[(lang) "$\\langle$"] [(lang) "$\\langle$"]
@ -674,10 +737,10 @@
(define/override (table-of-contents sec ri) (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 plain null))
(define/override (local-table-of-contents part ri style) (define/override (local-table-of-contents part ri style)
(make-paragraph null)) (make-paragraph plain null))
;; ---------------------------------------- ;; ----------------------------------------

9
collects/scribble/latex-variants.ss Normal file
View File

@ -0,0 +1,9 @@
#lang scheme/base
(require "private/provide-structs.ss"
scheme/contract)
(provide-structs
[tex-addition ([path (or/c path-string? (cons/c 'collects (listof bytes?)))])]
[latex-defaults ([prefix (or/c bytes? path-string? (cons/c 'collects (listof bytes?)))]
[style (or/c bytes? path-string? (cons/c 'collects (listof bytes?)))]
[extra-files (listof (or/c path-string? (cons/c 'collects (listof bytes?))))])])

12
collects/scribble/manual-prefix.tex Normal file
View File

@ -0,0 +1,12 @@
% This is the prefix for PLT Scheme manuals
\documentclass{article}
\parskip=10pt
\parindent=0pt
\partopsep=0pt
% Adjust margins to match HTML width for
% fixed-width font
\advance \oddsidemargin by -0.15in
\advance \evensidemargin by -0.15in
\advance \textwidth by 0.3in

3
collects/scribble/manual-struct.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require "struct.ss" (require "core.ss"
"private/provide-structs.ss"
scheme/contract) scheme/contract)
(provide-structs (provide-structs

11
collects/scribble/manual-style.tex Normal file
View File

@ -0,0 +1,11 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Re-definitions for the PLT Scheme manual style
\renewcommand{\sectionNewpage}{\newpage}
\renewcommand{\preDoc}{\sloppy}
\renewcommand{\ChapRef}[2]{\SecRef{#1}{#2}}
\renewcommand{\SecRef}[2]{\S#1 ``#2''}
\renewcommand{\ChapRefUC}[2]{\SecRefUC{#1}{#2}}
\renewcommand{\SecRefUC}[2]{\SecRef{#1}{#2}}

4
collects/scribble/manual.ss
View File

@ -1,5 +1,5 @@
#lang scheme/base #lang scheme/base
(require "basic.ss" (require "base.ss"
"private/manual-style.ss" "private/manual-style.ss"
"private/manual-scheme.ss" "private/manual-scheme.ss"
"private/manual-mod.ss" "private/manual-mod.ss"
@ -15,7 +15,7 @@
(provide unsyntax (provide unsyntax
make-binding-redirect-elements make-binding-redirect-elements
defidentifier defidentifier
(all-from-out "basic.ss" (all-from-out "base.ss"
"private/manual-style.ss" "private/manual-style.ss"
"private/manual-scheme.ss" "private/manual-scheme.ss"
"private/manual-mod.ss" "private/manual-mod.ss"

21
collects/scribble/manual/lang.ss
View File

@ -1,4 +1,17 @@
#lang scheme #lang scheme/base
(require scribble/doclang scribble/manual) (require scribble/doclang
(provide (all-from-out scribble/doclang scribble/manual
scribble/manual)) "../private/defaults.ss")
(provide (except-out (all-from-out scribble/doclang) #%module-begin)
(all-from-out scribble/manual)
(rename-out [module-begin #%module-begin]))
(define-syntax-rule (module-begin id . body)
(#%module-begin id post-process () . body))
(define (post-process doc)
(add-defaults doc
(scribble-file "manual-prefix.tex")
(scribble-file "manual-style.tex")
null
#t))

2
collects/scribble/manual/lang/reader.ss
View File

@ -5,6 +5,6 @@ scribble/manual/lang
#:read scribble:read-inside #:read scribble:read-inside
#:read-syntax scribble:read-syntax-inside #:read-syntax scribble:read-syntax-inside
#:whole-body-readers? #t #:whole-body-readers? #t
#:wrapper1 (lambda (t) (list* 'doc '() (t))) #:wrapper1 (lambda (t) (cons 'doc (t)))
(require (prefix-in scribble: "../../reader.ss")) (require (prefix-in scribble: "../../reader.ss"))

28
collects/scribble/private/defaults.ss Normal file
View File

@ -0,0 +1,28 @@
#lang scheme/base
(require scribble/core
scribble/latex-variants
setup/main-collects)
(provide scribble-file
add-defaults)
(define (add-variant variants pred new)
(if (ormap pred variants)
variants
(cons new variants)))
(define (scribble-file s)
(path->main-collects-relative (build-path (collection-path "scribble") s)))
(define (add-defaults doc pfx styl extras version?)
(struct-copy part doc [style (make-style (style-name (part-style doc))
((if version? add-variant (lambda (x y z) x))
(add-variant
(style-variants (part-style doc))
latex-defaults?
(make-latex-defaults
pfx
styl
extras))
document-version?
(make-document-version (version))))]))

13
collects/scribble/private/manual-bind.ss
View File

@ -3,7 +3,6 @@
"../struct.ss" "../struct.ss"
"../scheme.ss" "../scheme.ss"
"../search.ss" "../search.ss"
"../config.ss"
"../basic.ss" "../basic.ss"
"../manual-struct.ss" "../manual-struct.ss"
"manual-ex.ss" "manual-ex.ss"
@ -52,10 +51,10 @@
[sd (and stag (resolve-get/tentative sec ri stag))]) [sd (and stag (resolve-get/tentative sec ri stag))])
(list (list
(make-element (make-element
"schemesymbol" symbol-color
(list (list
(cond [sd (make-link-element "schemesyntaxlink" (list s) stag)] (cond [sd (make-link-element syntax-link-color (list s) stag)]
[vtag (make-link-element "schemevaluelink" (list s) vtag)] [vtag (make-link-element value-link-color (list s) vtag)]
[else s])))))) [else s]))))))
(lambda () s) (lambda () s)
(lambda () s)))) (lambda () s))))
@ -232,12 +231,12 @@
(list (symbol->string id)) (list (symbol->string id))
(list (list
(make-element (make-element
"schemesymbol" symbol-color
(list (list
(make-element (make-element
(if form? (if form?
"schemesyntaxlink" syntax-link-color
"schemevaluelink") value-link-color)
(list (symbol->string id)))))) (list (symbol->string id))))))
((if form? ((if form?
make-form-index-desc make-form-index-desc

5
collects/scribble/private/manual-class.ss
View File

@ -3,7 +3,6 @@
"../struct.ss" "../struct.ss"
"../scheme.ss" "../scheme.ss"
"../search.ss" "../search.ss"
"../config.ss"
"../basic.ss" "../basic.ss"
"../manual-struct.ss" "../manual-struct.ss"
"qsloc.ss" "qsloc.ss"
@ -134,9 +133,9 @@
`(cls/intf ,(cadr tag)) `(cls/intf ,(cadr tag))
(make-cls/intf (make-cls/intf
(make-element (make-element
"schemesymbol" symbol-color
(list (make-link-element (list (make-link-element
"schemevaluelink" value-link-color
(list (symbol->string (syntax-e (decl-name decl)))) (list (symbol->string (syntax-e (decl-name decl))))
tag))) tag)))
(map id-info (decl-app-mixins decl)) (map id-info (decl-app-mixins decl))

1
collects/scribble/private/manual-form.ss
View File

@ -3,7 +3,6 @@
"../struct.ss" "../struct.ss"
"../scheme.ss" "../scheme.ss"
"../search.ss" "../search.ss"
"../config.ss"
"../basic.ss" "../basic.ss"
"../manual-struct.ss" "../manual-struct.ss"
"qsloc.ss" "qsloc.ss"

4
collects/scribble/private/manual-method.ss
View File

@ -34,8 +34,8 @@
(lambda (c mk) (mk id/tag))) (lambda (c mk) (mk id/tag)))
content content
(lambda (tag) (lambda (tag)
(make-element "schemesymbol" (make-element symbol-color
(list (make-link-element "schemevaluelink" content (list (make-link-element value-link-color content
(method-tag tag sym)))))))) (method-tag tag sym))))))))
(define (method-tag vtag sym) (define (method-tag vtag sym)

7
collects/scribble/private/manual-proc.ss
View File

@ -3,7 +3,6 @@
"../struct.ss" "../struct.ss"
"../scheme.ss" "../scheme.ss"
"../search.ss" "../search.ss"
"../config.ss"
"../basic.ss" "../basic.ss"
"../manual-struct.ss" "../manual-struct.ss"
"qsloc.ss" "qsloc.ss"
@ -27,9 +26,9 @@
*defthing) *defthing)
(define dots0 (define dots0
(make-element "schememeta" (list "..."))) (make-element meta-color (list "...")))
(define dots1 (define dots1
(make-element "schememeta" (list "...+"))) (make-element meta-color (list "...+")))
(define (make-openers n) (define (make-openers n)
(schemeparenfont (schemeparenfont
@ -772,7 +771,7 @@
(list content) (list content)
tag tag
(list name) (list name)
(list (schemeidfont (make-element "schemevaluelink" (list (schemeidfont (make-element value-link-color
(list name)))) (list name))))
(with-exporting-libraries (with-exporting-libraries
(lambda (libs) (lambda (libs)

6
collects/scribble/private/manual-scheme.ss
View File

@ -57,9 +57,9 @@
(syntax/loc stx (schememod #:file #f lang rest ...))])) (syntax/loc stx (schememod #:file #f lang rest ...))]))
(define (to-element/result s) (define (to-element/result s)
(make-element "schemeresult" (list (to-element/no-color s)))) (make-element result-color (list (to-element/no-color s))))
(define (to-element/id s) (define (to-element/id s)
(make-element "schemesymbol" (list (to-element/no-color s)))) (make-element symbol-color (list (to-element/no-color s))))
(define-syntax (keep-s-expr stx) (define-syntax (keep-s-expr stx)
(syntax-case stx () (syntax-case stx ()
@ -106,7 +106,7 @@
(define (as-modname-link s e) (define (as-modname-link s e)
(if (symbol? s) (if (symbol? s)
(make-link-element "schememodlink" (make-link-element module-link-color
(list e) (list e)
`(mod-path ,(symbol->string s))) `(mod-path ,(symbol->string s)))
e)) e))

126
collects/scribble/private/manual-style.ss
View File

@ -1,30 +1,34 @@
#lang scheme/base #lang scheme/base
(require "../decode.ss" (require "../decode.ss"
"../struct.ss" "../struct.ss"
"../basic.ss" "../base.ss"
(only-in "../basic.ss" aux-elem itemize)
"../scheme.ss"
(only-in "../core.ss" make-style plain)
"manual-utils.ss" "manual-utils.ss"
scheme/list scheme/list
scheme/string) scheme/string)
(provide PLaneT etc (provide PLaneT etc
litchar verbatim litchar
image image/plain onscreen menuitem defterm emph image (rename-out [image image/plain]) onscreen menuitem defterm
schemefont schemevalfont schemeresultfont schemeidfont schemevarfont schemefont schemevalfont schemeresultfont schemeidfont schemevarfont
schemeparenfont schemekeywordfont schememetafont schememodfont schemeparenfont schemekeywordfont schememetafont schememodfont
schemeerror schemeerror schemeoutput
filepath exec envvar Flag DFlag PFlag DPFlag filepath exec envvar Flag DFlag PFlag DPFlag
indexed-file indexed-envvar indexed-file indexed-envvar
link procedure (rename-out [hyperlink link])
(rename-out [other-doc other-manual])
(rename-out [centered centerline])
itemize
procedure
idefterm idefterm
t inset-flow t inset-flow
pidefterm pidefterm
hash-lang hash-lang
centerline
commandline commandline
elemtag elemref
secref seclink other-manual
margin-note
void-const undefined-const void-const undefined-const
aux-elem
math) math)
(define PLaneT (make-element "planetName" '("PLaneT"))) (define PLaneT (make-element "planetName" '("PLaneT")))
@ -37,51 +41,20 @@
(let ([s (string-append* (map (lambda (s) (regexp-replace* "\n" s " ")) (let ([s (string-append* (map (lambda (s) (regexp-replace* "\n" s " "))
strs))]) strs))])
(if (regexp-match? #rx"^ *$" s) (if (regexp-match? #rx"^ *$" s)
(make-element "schemeinputbg" (list (hspace (string-length s)))) (make-element input-background-color (list (hspace (string-length s))))
(let ([^spaces (car (regexp-match-positions #rx"^ *" s))] (let ([^spaces (car (regexp-match-positions #rx"^ *" s))]
[$spaces (car (regexp-match-positions #rx" *$" s))]) [$spaces (car (regexp-match-positions #rx" *$" s))])
(make-element (make-element
"schemeinputbg" input-background-color
(list (hspace (cdr ^spaces)) (list (hspace (cdr ^spaces))
(make-element "schemeinput" (make-element input-color
(list (substring s (cdr ^spaces) (car $spaces)))) (list (substring s (cdr ^spaces) (car $spaces))))
(hspace (- (cdr $spaces) (car $spaces))))))))) (hspace (- (cdr $spaces) (car $spaces)))))))))
(define (verbatim #:indent [i 0] s . more)
(define indent
(if (zero? i)
values
(let ([hs (hspace i)]) (lambda (x) (cons hs x)))))
(define strs (regexp-split #rx"\n" (string-append* s more)))
(define (str->elts str)
(let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)])
(if spaces
(list* (substring str 0 (caar spaces))
(hspace (- (cdar spaces) (caar spaces)))
(str->elts (substring str (cdar spaces))))
(list (make-element 'tt (list str))))))
(define (make-line str)
(let* ([line (indent (str->elts str))]
[line (list (make-element 'tt line))])
(list (make-flow (list (make-omitable-paragraph line))))))
(make-table #f (map make-line strs)))
;; String String *-> Element
;; an in-lined image, relative to the current directory
(define (image #:scale [scale 1.0] filename-relative-to-source . alt)
(make-element (make-image-file filename-relative-to-source scale)
(decode-content alt)))
(define (image/plain filename-relative-to-source . alt)
(make-element (make-image-file filename-relative-to-source 1.0)
(decode-content alt)))
(define (onscreen . str) (define (onscreen . str)
(make-element 'sf (decode-content str))) (make-element 'sf (decode-content str)))
(define (menuitem menu item) (define (menuitem menu item)
(make-element 'sf (list menu "|" item))) (make-element 'sf (list menu "|" item)))
(define (emph . str)
(make-element 'italic (decode-content str)))
(define (defterm . str) (define (defterm . str)
(make-element 'italic (decode-content str))) (make-element 'italic (decode-content str)))
(define (idefterm . str) (define (idefterm . str)
@ -90,21 +63,21 @@
(define (schemefont . str) (define (schemefont . str)
(apply tt str)) (apply tt str))
(define (schemevalfont . str) (define (schemevalfont . str)
(make-element "schemevalue" (decode-content str))) (make-element value-color (decode-content str)))
(define (schemeresultfont . str) (define (schemeresultfont . str)
(make-element "schemeresult" (decode-content str))) (make-element result-color (decode-content str)))
(define (schemeidfont . str) (define (schemeidfont . str)
(make-element "schemesymbol" (decode-content str))) (make-element symbol-color (decode-content str)))
(define (schemevarfont . str) (define (schemevarfont . str)
(make-element "schemevariable" (decode-content str))) (make-element variable-color (decode-content str)))
(define (schemeparenfont . str) (define (schemeparenfont . str)
(make-element "schemeparen" (decode-content str))) (make-element paren-color (decode-content str)))
(define (schememetafont . str) (define (schememetafont . str)
(make-element "schememeta" (decode-content str))) (make-element meta-color (decode-content str)))
(define (schememodfont . str) (define (schememodfont . str)
(make-element "schememod" (decode-content str))) (make-element module-color (decode-content str)))
(define (schemekeywordfont . str) (define (schemekeywordfont . str)
(make-element "schemekeyword" (decode-content str))) (make-element keyword-color (decode-content str)))
(define (filepath . str) (define (filepath . str)
(make-element 'tt (append (list "\"") (decode-content str) (list "\"")))) (make-element 'tt (append (list "\"") (decode-content str) (list "\""))))
(define (indexed-file . str) (define (indexed-file . str)
@ -141,17 +114,12 @@
[s (element->string f)]) [s (element->string f)])
(index* (list s) (list f) f))) (index* (list s) (list f) f)))
(define (procedure . str) (define (procedure . str)
(make-element "schemeresult" `("#<procedure:" ,@(decode-content str) ">"))) (make-element result-color `("#<procedure:" ,@(decode-content str) ">")))
(define (link url
#:underline? [underline? #t]
#:style [style (if underline? #f "plainlink")]
. str)
(make-element (make-target-url url style)
(decode-content str)))
(define (schemeoutput . str)
(make-element output-color (decode-content str)))
(define (schemeerror . str) (define (schemeerror . str)
(make-element "schemeerror" (decode-content str))) (make-element error-color (decode-content str)))
(define (t . str) (define (t . str)
(decode-paragraph str)) (decode-paragraph str))
@ -159,11 +127,6 @@
(define (inset-flow . c) (define (inset-flow . c)
(make-blockquote "insetpara" (flow-paragraphs (decode-flow c)))) (make-blockquote "insetpara" (flow-paragraphs (decode-flow c))))
(define (centerline . s)
(make-blockquote "SCentered" (flow-paragraphs (decode-flow s))))
(define (commandline . s) (define (commandline . s)
(make-paragraph (cons (hspace 2) (map (lambda (s) (make-paragraph (cons (hspace 2) (map (lambda (s)
(if (string? s) (if (string? s)
@ -171,20 +134,6 @@
s)) s))
s)))) s))))
(define (elemtag t . body)
(make-target-element #f (decode-content body) `(elem ,t)))
(define (elemref #:underline? [u? #t] t . body)
(make-link-element (if u? #f "plainlink") (decode-content body) `(elem ,t)))
(define (secref s #:underline? [u? #t] #:doc [doc #f] #:tag-prefixes [prefix #f])
(make-link-element (if u? #f "plainlink") null `(part ,(doc-prefix doc prefix s))))
(define (seclink tag #:underline? [u? #t] #:doc [doc #f] #:tag-prefixes [prefix #f] . s)
(make-link-element (if u? #f "plainlink") (decode-content s)
`(part ,(doc-prefix doc prefix tag))))
(define (other-manual #:underline? [u? #t] doc)
(secref #:doc doc #:underline? u? "top"))
(define (pidefterm . s) (define (pidefterm . s)
(let ([c (apply defterm s)]) (let ([c (apply defterm s)])
(index (string-append (content->string (element-content c)) "s") (index (string-append (content->string (element-content c)) "s")
@ -192,26 +141,21 @@
(define (hash-lang) (define (hash-lang)
(make-link-element (make-link-element
"schememodlink" module-link-color
(list (schememodfont "#lang")) (list (schememodfont "#lang"))
`(part ,(doc-prefix '(lib "scribblings/guide/guide.scrbl") "hash-lang")))) `(part ,(doc-prefix '(lib "scribblings/guide/guide.scrbl") "hash-lang"))))
(define (margin-note . c)
(make-blockquote
"\\refpara"
(list
(make-blockquote
"refcolumn"
(list
(make-blockquote
"refcontent"
(flow-paragraphs (decode-flow c))))))))
(define void-const (define void-const
(schemeresultfont "#<void>")) (schemeresultfont "#<void>"))
(define undefined-const (define undefined-const
(schemeresultfont "#<undefined>")) (schemeresultfont "#<undefined>"))
(define (link url
#:underline? [underline? #t]
#:style [style (if underline? #f "plainlink")]
. str)
(apply hyperlink url #:style (if style (make-style style null) plain) str))
(define (math . s) (define (math . s)
(let ([c (decode-content s)]) (let ([c (decode-content s)])
(make-element (make-element

13
collects/scribble/private/manual-utils.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base #lang scheme/base
(require "../struct.ss" (require "../struct.ss"
"../decode.ss" "../decode.ss"
"../basic.ss" "../base.ss"
scheme/list) scheme/list)
(provide spacer doc-prefix (provide spacer doc-prefix
@ -12,17 +12,6 @@
(define spacer (hspace 1)) (define spacer (hspace 1))
(define doc-prefix
(case-lambda
[(doc s)
(if doc
(list (module-path-prefix->string doc) s)
s)]
[(doc prefix s)
(doc-prefix doc (if prefix
(append prefix (list s))
s))]))
(define (to-flow e) (define (to-flow e)
(make-flow (list (make-omitable-paragraph (list e))))) (make-flow (list (make-omitable-paragraph (list e)))))
(define flow-spacer (to-flow spacer)) (define flow-spacer (to-flow spacer))

3
collects/scribble/private/manual-vars.ss
View File

@ -2,6 +2,7 @@
(require "../decode.ss" (require "../decode.ss"
"../scheme.ss" "../scheme.ss"
"../struct.ss" "../struct.ss"
(only-in "../core.ss" style-name)
(for-syntax scheme/base (for-syntax scheme/base
syntax/kerncase syntax/kerncase
syntax/boundmap) syntax/boundmap)
@ -108,7 +109,7 @@
(unless (and (box-splice? box) (unless (and (box-splice? box)
(= 1 (length (splice-run box))) (= 1 (length (splice-run box)))
(table? (car (splice-run box))) (table? (car (splice-run box)))
(eq? 'boxed (table-style (car (splice-run box))))) (eq? 'boxed (style-name (table-style (car (splice-run box))))))
(error 'deftogether (error 'deftogether
"element is not a boxing splice containing a single table: ~e" "element is not a boxing splice containing a single table: ~e"
box)) box))

37
collects/scribble/private/provide-structs.ss Normal file
View File

@ -0,0 +1,37 @@
#lang scheme/base
(require scheme/serialize
scheme/contract
(for-syntax scheme/base))
(provide provide-structs)
(define-syntax (provide-structs stx)
(syntax-case stx ()
[(_ (id ([field ct] ...)) ...)
#`(begin
(define-serializable-struct id (field ...)) ...
(provide/contract
#,@(let ([ids (syntax->list #'(id ...))]
[fields+cts (syntax->list #'(([field ct] ...) ...))])
(define (get-fields super-id)
(ormap (lambda (id fields+cts)
(if (identifier? id)
(and (free-identifier=? id super-id)
fields+cts)
(syntax-case id ()
[(my-id next-id)
(free-identifier=? #'my-id super-id)
#`[#,@(get-fields #'next-id)
#,@fields+cts]]
[_else #f])))
ids fields+cts))
(map (lambda (id fields+cts)
(if (identifier? id)
#`[struct #,id #,fields+cts]
(syntax-case id ()
[(id super)
#`[struct id (#,@(get-fields #'super)
#,@fields+cts)]])))
ids
fields+cts))))]))

55
collects/scribble/private/render-utils.ss Normal file
View File

@ -0,0 +1,55 @@
#lang scheme/base
(require "../core.ss")
(provide part-style?
select-suffix
extract-table-cell-styles
empty-content?)
(define (part-style? p s)
(memq s (style-variants (part-style p))))
(define (select-suffix path suggested-suffixes accepted-suffixes)
(or (ormap (lambda (suggested)
(and (member suggested accepted-suffixes)
(let ([p (bytes->path
(bytes-append (path->bytes (if (string? path)
(string->path path)
path))
(string->bytes/utf-8 suggested)))])
(and (file-exists? p)
p))))
suggested-suffixes)
path))
(define (extract-table-cell-styles t)
(let ([vars (style-variants (table-style t))])
(or (let ([l (ormap (lambda (v)
(and (table-cells? v)
(table-cells-styless v)))
vars)])
(and l
(unless (= (length l) (length (table-blockss t)))
(error 'table
"table-cells variant list's length does not match row count: ~e vs. ~e"
l (length (table-blockss t))))
(for-each (lambda (l row)
(unless (= (length l) (length row))
(error 'table
"table-cells variant list contains a row whose length does not match the content: ~e vs. ~e"
l (length row))))
l (table-blockss t))
l))
(let ([cols (ormap (lambda (v) (and (table-columns? v) v)) vars)])
(and cols
(let ([cols (table-columns-styles cols)])
(map (lambda (row)
(unless (= (length cols) (length row))
(error 'table
"table-columns variant list's length does not match a row length: ~e vs. ~e"
cols (length row)))
cols)
(table-blockss t)))))
(map (lambda (row) (map (lambda (c) plain) row)) (table-blockss t)))))
(define (empty-content? c) (null? c))

4
collects/scribble/run.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require "struct.ss" (require "core.ss"
"base-render.ss" "base-render.ss"
"xref.ss" "xref.ss"
scheme/cmdline scheme/cmdline
@ -64,7 +64,7 @@
#:multi #:multi
[("++extra") file "add given file" [("++extra") file "add given file"
(current-extra-files (cons file (current-extra-files)))] (current-extra-files (cons file (current-extra-files)))]
[("++style") file "add given .css/.tex file" [("++style") file "add given .css/.tex file after others"
(current-style-extra-files (cons file (current-style-extra-files)))] (current-style-extra-files (cons file (current-style-extra-files)))]
[("++info-in") file "load format-specific link information from <file>" [("++info-in") file "load format-specific link information from <file>"
(current-info-input-files (current-info-input-files

166
collects/scribble/scheme.css Normal file
View File

@ -0,0 +1,166 @@
/* See the beginning of "scribble.css". */
/* Monospace: */
.ScmIn, .ScmRdr, .ScmPn, .ScmMeta,
.ScmMod, .ScmKw, .ScmVar, .ScmSym,
.ScmRes, .ScmOut, .ScmCmt, .ScmVal {
font-family: monospace;
}
/* Serif: */
.inheritedlbl {
font-family: serif;
}
/* ---------------------------------------- */
/* Inherited methods, left margin */
.inherited {
width: 100%;
margin-top: 0.5em;
text-align: left;
background-color: #ECF5F5;
}
.inherited td {
font-size: 82%;
padding-left: 1em;
text-indent: -0.8em;
padding-right: 0.2em;
}
.inheritedlbl {
font-style: italic;
}
/* ---------------------------------------- */
/* Scheme text styles */
.ScmIn {
color: #cc6633;
background-color: #eeeeee;
}
.ScmInBG {
background-color: #eeeeee;
}
.ScmRdr {
}
.ScmPn {
color: #843c24;
}
.ScmMeta {
color: #262680;
}
.ScmMod {
color: black;
}
.ScmOpt {
color: black;
}
.ScmKw {
color: black;
font-weight: bold;
}
.ScmErr {
color: red;
font-style: italic;
}
.ScmVar {
color: #262680;
font-style: italic;
}
.ScmSym {
color: #262680;
}
.ScmValLink {
text-decoration: none;
color: blue;
}
.ScmModLink {
text-decoration: none;
color: blue;
}
.ScmStxLink {
text-decoration: none;
color: black;
font-weight: bold;
}
.ScmRes {
color: #0000af;
}
.ScmOut {
color: #960096;
}
.ScmCmt {
color: #c2741f;
}
.ScmVal {
color: #228b22;
}
/* ---------------------------------------- */
/* Some inline styles */
.together {
width: 100%;
}
.prototype td {
vertical-align: text-top;
}
.longprototype td {
vertical-align: bottom;
}
.ScmBlk td {
vertical-align: baseline;
}
.argcontract td {
vertical-align: text-top;
}
.highlighted {
background-color: #ddddff;
}
.defmodule {
width: 100%;
background-color: #F5F5DC;
}
.specgrammar {
float: right;
}
.SBibliography td {
vertical-align: text-top;
}
.leftindent {
margin-left: 1em;
margin-right: 0em;
}
.insetpara {
margin-left: 1em;
margin-right: 1em;
}

112
collects/scribble/scheme.ss
View File

@ -1,7 +1,9 @@
(module scheme scheme/base (module scheme scheme/base
(require "struct.ss" (require "core.ss"
"basic.ss" "basic.ss"
"search.ss" "search.ss"
"html-variants.ss"
"latex-variants.ss"
mzlib/class mzlib/class
mzlib/for mzlib/for
setup/main-collects setup/main-collects
@ -20,6 +22,28 @@
current-variable-list current-variable-list
current-meta-list current-meta-list
input-color
output-color
input-background-color
no-color
reader-color
result-color
keyword-color
comment-color
paren-color
meta-color
value-color
symbol-color
variable-color
opt-color
error-color
syntax-link-color
value-link-color
module-color
module-link-color
block-color
highlighted-color
(struct-out var-id) (struct-out var-id)
(struct-out shaped-parens) (struct-out shaped-parens)
(struct-out just-context) (struct-out just-context)
@ -29,16 +53,38 @@
make-element-id-transformer make-element-id-transformer
element-id-transformer?)) element-id-transformer?))
(define no-color "schemeplain") (define scheme-variants
(define reader-color "schemereader") (let ([abs (lambda (s)
(define keyword-color "schemekeyword") (path->main-collects-relative (build-path (collection-path "scribble") s)))])
(define comment-color "schemecomment") (list (make-css-addition (abs "scheme.css"))
(define paren-color "schemeparen") (make-tex-addition (abs "scheme.tex")))))
(define meta-color "schememeta")
(define value-color "schemevalue") (define (make-scheme-style s #:tt? [tt? #t])
(define symbol-color "schemesymbol") (make-style s (if tt?
(define variable-color "schemevariable") (cons 'tt-chars scheme-variants)
(define opt-color "schemeopt") scheme-variants)))
(define output-color (make-scheme-style "ScmOut"))
(define input-color (make-scheme-style "ScmIn"))
(define input-background-color (make-scheme-style "ScmInBG"))
(define no-color (make-scheme-style "ScmPlain"))
(define reader-color (make-scheme-style "ScmRdr"))
(define result-color (make-scheme-style "ScmRes"))
(define keyword-color (make-scheme-style "ScmKw"))
(define comment-color (make-scheme-style "ScmCmt"))
(define paren-color (make-scheme-style "ScmPn"))
(define meta-color (make-scheme-style "ScmMeta"))
(define value-color (make-scheme-style "ScmVal"))
(define symbol-color (make-scheme-style "ScmSym"))
(define variable-color (make-scheme-style "ScmVar"))
(define opt-color (make-scheme-style "ScmOpt"))
(define error-color (make-scheme-style "ScmErr" #:tt? #f))
(define syntax-link-color (make-scheme-style "ScmStxLink"))
(define value-link-color (make-scheme-style "ScmValLink"))
(define module-color (make-scheme-style "ScmMod"))
(define module-link-color (make-scheme-style "ScmModLink"))
(define block-color (make-scheme-style "ScmBlk"))
(define highlighted-color (make-scheme-style "highlighted" #:tt? #f))
(define current-keyword-list (define current-keyword-list
(make-parameter null)) (make-parameter null))
@ -66,7 +112,7 @@
i))) i)))
(define line-breakable-space (make-element 'tt (list " "))) (define line-breakable-space (make-element 'tt " "))
;; These caches intentionally record a key with the value. ;; These caches intentionally record a key with the value.
;; That way, when the value is no longer used, the key ;; That way, when the value is no longer used, the key
@ -96,12 +142,12 @@
(list (list
(case (car tag) (case (car tag)
[(form) [(form)
(make-link-element "schemesyntaxlink" (list s) tag)] (make-link-element syntax-link-color (list s) tag)]
[else [else
(make-link-element "schemevaluelink" (list s) tag)])) (make-link-element value-link-color (list s) tag)]))
(list (list
(make-element "badlink" (make-element "badlink"
(list (make-element "schemevaluelink" (list s)))))))) (make-element value-link-color s))))))
(lambda () s) (lambda () s)
(lambda () s) (lambda () s)
key)]) key)])
@ -111,10 +157,8 @@
(define (make-element/cache style content) (define (make-element/cache style content)
(if (and element-cache (if (and element-cache
(pair? content) (string? content))
(string? (car content)) (let ([key (vector style content)])
(null? (cdr content)))
(let ([key (vector style (car content))])
(let ([b (hash-ref element-cache key #f)]) (let ([b (hash-ref element-cache key #f)])
(or (and b (weak-box-value b)) (or (and b (weak-box-value b))
(let ([e (make-cached-element style content key)]) (let ([e (make-cached-element style content key)])
@ -184,6 +228,8 @@
[else paren-color]) [else paren-color])
(string-length s)))))) (string-length s))))))
(define omitable (make-style #f '(omitable)))
(define (gen-typeset c multi-line? prefix1 prefix suffix color?) (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]
@ -200,7 +246,7 @@
[line (or (syntax-line first) 0)]) [line (or (syntax-line first) 0)])
(define (finish-line!) (define (finish-line!)
(when multi-line? (when multi-line?
(set! docs (cons (make-flow (list (make-omitable-paragraph (reverse content)))) (set! docs (cons (make-paragraph omitable (reverse content))
docs)) docs))
(set! content null))) (set! content null)))
(define out (define out
@ -209,16 +255,14 @@
(out v cls (let sz-loop ([v v]) (out v cls (let sz-loop ([v v])
(cond (cond
[(string? v) (string-length v)] [(string? v) (string-length v)]
[(list? v) (for/fold ([s 0]) ([v (in-list v)]) (+ s (sz-loop v)))]
[(sized-element? v) (sized-element-length v)] [(sized-element? v) (sized-element-length v)]
[(and (element? v)
(= 1 (length (element-content v))))
(sz-loop (car (element-content v)))]
[(element? v) [(element? v)
(element-width v)] (sz-loop (element-content v))]
[(delayed-element? v) [(delayed-element? v)
(element-width v)] (content-width v)]
[(part-relative-element? v) [(part-relative-element? v)
(element-width v)] (content-width v)]
[(spaces? v) [(spaces? v)
(+ (sz-loop (car (element-content v))) (+ (sz-loop (car (element-content v)))
(spaces-cnt v) (spaces-cnt v)
@ -240,10 +284,10 @@
[else [else
(set! content (cons ((if highlight? (set! content (cons ((if highlight?
(lambda (c) (lambda (c)
(make-element "highlighted" (list c))) (make-element highlighted-color c))
values) values)
(if (and color? cls) (if (and color? cls)
(make-element/cache cls (list v)) (make-element/cache cls v)
v)) v))
content)) content))
(set! dest-col (+ dest-col len))]))])) (set! dest-col (+ dest-col len))]))]))
@ -300,9 +344,9 @@
(make-sized-element (make-sized-element
(if val? value-color #f) (if val? value-color #f)
(list (list
(make-element/cache (if val? value-color paren-color) '(". ")) (make-element/cache (if val? value-color paren-color) '". ")
(typeset a #f "" "" "" (not val?)) (typeset a #f "" "" "" (not val?))
(make-element/cache (if val? value-color paren-color) '(" ."))) (make-element/cache (if val? value-color paren-color) '" ."))
(+ (syntax-span a) 4))) (+ (syntax-span a) 4)))
(list (syntax-source a) (list (syntax-source a)
(syntax-line a) (syntax-line a)
@ -564,8 +608,8 @@
(finish-line!)) (finish-line!))
(if multi-line? (if multi-line?
(if (= 1 (length docs)) (if (= 1 (length docs))
(car (flow-paragraphs (car docs))) (car docs)
(make-table "schemeblock" (map list (reverse docs)))) (make-table block-color (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?) (define (typeset c multi-line? prefix1 prefix suffix color?)
@ -590,8 +634,8 @@
[(elem color len) [(elem color len)
(if (and (string? elem) (if (and (string? elem)
(= len (string-length elem))) (= len (string-length elem)))
(make-element/cache (and color? color) (list elem)) (make-element/cache (and color? color) elem)
(make-sized-element (and color? color) (list elem) len))])]) (make-sized-element (and color? color) elem len))])])
mk) mk)
color? 0)))) color? 0))))

52
collects/scribble/scheme.tex Normal file
View File

@ -0,0 +1,52 @@
% Redefine \SColorize to produce B&W Scheme text
\newcommand{\SColorize}[2]{\color{#1}{#2}}
\newcommand{\inColor}[2]{{\Scribtexttt{\SColorize{#1}{#2}}}}
\definecolor{PaleBlue}{rgb}{0.90,0.90,1.0}
\definecolor{LightGray}{rgb}{0.90,0.90,0.90}
\definecolor{CommentColor}{rgb}{0.76,0.45,0.12}
\definecolor{ParenColor}{rgb}{0.52,0.24,0.14}
\definecolor{IdentifierColor}{rgb}{0.15,0.15,0.50}
\definecolor{ResultColor}{rgb}{0.0,0.0,0.69}
\definecolor{ValueColor}{rgb}{0.13,0.55,0.13}
\definecolor{OutputColor}{rgb}{0.59,0.00,0.59}
\newcommand{\ScmPlain}[1]{\inColor{black}{#1}}
\newcommand{\ScmKw}[1]{{\SColorize{black}{\Scribtexttt{\textbf{#1}}}}}
\newcommand{\ScmStxLink}[1]{\ScmKw{#1}}
\newcommand{\ScmCmt}[1]{\inColor{CommentColor}{#1}}
\newcommand{\ScmPn}[1]{\inColor{ParenColor}{#1}}
\newcommand{\ScmInBG}[1]{\inColor{ParenColor}{#1}}
\newcommand{\ScmSym}[1]{\inColor{IdentifierColor}{#1}}
\newcommand{\ScmVal}[1]{\inColor{ValueColor}{#1}}
\newcommand{\ScmValLink}[1]{\inColor{blue}{#1}}
\newcommand{\ScmModLink}[1]{\inColor{blue}{#1}}
\newcommand{\ScmRes}[1]{\inColor{ResultColor}{#1}}
\newcommand{\ScmOut}[1]{\inColor{OutputColor}{#1}}
\newcommand{\ScmMeta}[1]{\inColor{IdentifierColor}{#1}}
\newcommand{\ScmMod}[1]{\inColor{black}{#1}}
\newcommand{\ScmRdr}[1]{\inColor{black}{#1}}
\newcommand{\ScmVarCol}[1]{\inColor{IdentifierColor}{#1}}
\newcommand{\ScmVar}[1]{{\ScmVarCol{\textsl{#1}}}}
\newcommand{\ScmErrCol}[1]{\inColor{red}{#1}}
\newcommand{\ScmErr}[1]{{\ScmErrCol{\textrm{\textit{#1}}}}}
\newcommand{\ScmOpt}[1]{#1}
\newcommand{\ScmIn}[1]{\incolorbox{LightGray}{\ScmInBG{#1}}}
\newcommand{\highlighted}[1]{\colorbox{PaleBlue}{\hspace{-0.5ex}\ScmInBG{#1}\hspace{-0.5ex}}}
\newenvironment{ScmBlk}{}{}
\newenvironment{defmodule}{}{}
\newenvironment{prototype}{}{}
\newenvironment{argcontract}{}{}
\newenvironment{together}{}{}
\newenvironment{specgrammar}{}{}
\newenvironment{SBibliography}{}{}
\newcommand{\bibentry}[1]{\parbox[t]{0.8\linewidth}{#1}}
\newenvironment{leftindent}{\begin{quote}}{\end{quote}}
\newenvironment{insetpara}{\begin{quote}}{\end{quote}}

10
collects/scribble/scribble-prefix.tex
View File

@ -1,12 +1,2 @@
% This is the default prefix for Scribble-generated Latex % This is the default prefix for Scribble-generated Latex
\documentclass{article} \documentclass{article}
\parskip=10pt
\parindent=0pt
\partopsep=0pt
% Adjust margins to match HTML width for
% fixed-width font
\advance \oddsidemargin by -0.15in
\advance \evensidemargin by -0.15in
\advance \textwidth by 0.3in

0
collects/scribble/scribble-style.css Normal file
View File

0
collects/scribble/scribble-style.tex Normal file
View File

204
collects/scribble/scribble.css
View File

@ -8,20 +8,17 @@
see if any font is set. */ see if any font is set. */
/* Monospace: */ /* Monospace: */
.maincolumn, .refpara, .tocset, .stt, .hspace, .maincolumn, .refpara, .tocset, .stt, .hspace {
.schemeinput, .schemereader, .schemeparen, .schememeta,
.schememod, .schemekeyword, .schemevariable, .schemesymbol,
.schemeresult, .schemestdout, .schemecomment, .schemevalue {
font-family: monospace; font-family: monospace;
} }
/* Serif: */ /* Serif: */
.main, .refcontent, .tocview, .tocsub, .inheritedlbl, i { .main, .refcontent, .tocview, .tocsub, i {
font-family: serif; font-family: serif;
} }
/* Sans-serif: */ /* Sans-serif: */
.version { .version, .versionNoNav {
font-family: sans-serif; font-family: sans-serif;
} }
@ -136,6 +133,9 @@ table td {
.version { .version {
font-size: small; font-size: small;
} }
.versionNoNav {
font-size: xx-small; /* avoid overlap with author */
}
/* ---------------------------------------- */ /* ---------------------------------------- */
/* Margin notes */ /* Margin notes */
@ -292,122 +292,9 @@ table td {
font-size: 70%; font-size: 70%;
} }
/* ---------------------------------------- */
/* Inherited methods, left margin */
.inherited {
width: 100%;
margin-top: 0.5em;
text-align: left;
background-color: #ECF5F5;
}
.inherited td {
font-size: 82%;
padding-left: 1em;
text-indent: -0.8em;
padding-right: 0.2em;
}
.inheritedlbl {
font-style: italic;
}
/* ---------------------------------------- */
/* Scheme text styles */
.schemeinput {
color: #cc6633;
background-color: #eeeeee;
}
.schemeinputbg {
background-color: #eeeeee;
}
.schemereader {
}
.schemeparen {
color: #843c24;
}
.schememeta {
color: #262680;
}
.schememod {
color: black;
}
.schemeopt {
color: black;
}
.schemekeyword {
color: black;
font-weight: bold;
}
.schemeerror {
color: red;
font-style: italic;
}
.schemevariable {
color: #262680;
font-style: italic;
}
.schemesymbol {
color: #262680;
}
.schemevaluelink {
text-decoration: none;
color: blue;
}
.schememodlink {
text-decoration: none;
color: blue;
}
.schemesyntaxlink {
text-decoration: none;
color: black;
font-weight: bold;
}
.schemeresult {
color: #0000af;
}
.schemestdout {
color: #960096;
}
.schemecomment {
color: #c2741f;
}
.schemevalue {
color: #228b22;
}
/* ---------------------------------------- */ /* ---------------------------------------- */
/* Some inline styles */ /* Some inline styles */
.leftindent {
margin-left: 1em;
margin-right: 0em;
}
.insetpara {
margin-left: 1em;
margin-right: 1em;
}
.indexlink { .indexlink {
text-decoration: none; text-decoration: none;
} }
@ -437,52 +324,15 @@ ol ol ol ol { list-style-type: upper-alpha; }
i { i {
} }
.SubFlow {
display: block;
}
.boxed { .boxed {
width: 100%; width: 100%;
background-color: #E8E8FF; background-color: #E8E8FF;
} }
.inlinetop{
display: inline;
vertical-align: text-top;
}
.together {
width: 100%;
}
.prototype td {
vertical-align: text-top;
}
.longprototype td {
vertical-align: bottom;
}
.schemeblock td {
vertical-align: baseline;
}
.argcontract td {
vertical-align: text-top;
}
.ghost {
color: white;
}
.highlighted {
background-color: #ddddff;
}
.defmodule {
width: 100%;
background-color: #F5F5DC;
}
.specgrammar {
float: right;
}
.hspace { .hspace {
} }
@ -490,14 +340,6 @@ i {
font-style: oblique; font-style: oblique;
} }
.inferencetop td {
border-bottom: 1px solid black;
text-align: center;
}
.inferencebottom td {
text-align: center;
}
.badlink { .badlink {
text-decoration: underline; text-decoration: underline;
color: red; color: red;
@ -518,10 +360,6 @@ i {
.techinside:hover { color: blue; } .techinside:hover { color: blue; }
.techoutside:hover>.techinside { color: inherit; } .techoutside:hover>.techinside { color: inherit; }
.SBibliography td {
vertical-align: text-top;
}
.SCentered { .SCentered {
text-align: center; text-align: center;
} }
@ -531,10 +369,14 @@ i {
margin-right: 0.3em; margin-right: 0.3em;
} }
.smaller{ .Smaller{
font-size: 82%; font-size: 82%;
} }
.Larger{
font-size: 122%;
}
/* A hack, inserted to break some Scheme ids: */ /* A hack, inserted to break some Scheme ids: */
.mywbr { .mywbr {
width: 0; width: 0;
@ -550,16 +392,22 @@ i {
border: 0; border: 0;
} }
.author { .SAuthorListBox {
position: relative; position: relative;
float: right; float: right;
left: 2em; left: 2em;
top: -3em; top: -2.5em;
height: 0em; height: 0em;
width: 23em; /* very wide to keep author names on separate lines */ width: 13em;
margin: 0em -23em 0em 0em; margin: 0em -13em 0em 0em;
}
.SAuthorList {
font-size: 82%; font-size: 82%;
} }
.author:before { .SAuthorList:before {
content: "by "; content: "by ";
} }
.author {
display: inline;
white-space: nowrap;
}

125
collects/scribble/scribble.tex
View File

@ -11,47 +11,36 @@
\usepackage[usenames,dvipsnames]{color} \usepackage[usenames,dvipsnames]{color}
\hypersetup{bookmarks=true,bookmarksopen=true,bookmarksnumbered=true} \hypersetup{bookmarks=true,bookmarksopen=true,bookmarksnumbered=true}
\newcommand{\SColorize}[2]{\color{#1}{#2}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Configuration that is especially meant to be overridden:
\newcommand{\inColor}[2]{{\Scribtexttt{\SColorize{#1}{#2}}}} % Inserted before every ``chapter'', useful for starting each one on a new page:
\definecolor{CommentColor}{rgb}{0.76,0.45,0.12} \newcommand{\sectionNewpage}{}
\definecolor{ParenColor}{rgb}{0.52,0.24,0.14}
\definecolor{IdentifierColor}{rgb}{0.15,0.15,0.50}
\definecolor{ResultColor}{rgb}{0.0,0.0,0.69}
\definecolor{ValueColor}{rgb}{0.13,0.55,0.13}
\definecolor{OutputColor}{rgb}{0.59,0.00,0.59}
\definecolor{PaleBlue}{rgb}{0.90,0.90,1.0}
\definecolor{LightGray}{rgb}{0.90,0.90,0.90}
% Hooks for actions within the `document' environment:
\newcommand{\preDoc}{}
\newcommand{\postDoc}{}
% Generated by `secref'; first arg is section number, second is section title:
\newcommand{\BookRef}[2]{\emph{#2}}
\newcommand{\ChapRef}[2]{\SecRef{#1}{#2}}
\newcommand{\SecRef}[2]{section~#1}
% Generated by `Secref':
\newcommand{\BookRefUC}[2]{\BookRef{#1}{#2}}
\newcommand{\ChapRefUC}[2]{\SecRefUC{#1}{#2}}
\newcommand{\SecRefUC}[2]{Section~#1}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Fonts
% Font commands used by generated text:
\newcommand{\Scribtexttt}[1]{{\texttt{#1}}} \newcommand{\Scribtexttt}[1]{{\texttt{#1}}}
\newcommand{\schemeplain}[1]{\inColor{black}{#1}}
\newcommand{\schemekeyword}[1]{{\SColorize{black}{\Scribtexttt{\textbf{#1}}}}}
\newcommand{\schemesyntaxlink}[1]{\schemekeyword{#1}}
\newcommand{\schemecomment}[1]{\inColor{CommentColor}{#1}}
\newcommand{\schemeparen}[1]{\inColor{ParenColor}{#1}}
\newcommand{\schemeinputbg}[1]{\inColor{ParenColor}{#1}}
\newcommand{\schemesymbol}[1]{\inColor{IdentifierColor}{#1}}
\newcommand{\schemevalue}[1]{\inColor{ValueColor}{#1}}
\newcommand{\schemevaluelink}[1]{\inColor{blue}{#1}}
\newcommand{\schememodlink}[1]{\inColor{blue}{#1}}
\newcommand{\schemeresult}[1]{\inColor{ResultColor}{#1}}
\newcommand{\schemestdout}[1]{\inColor{OutputColor}{#1}}
\newcommand{\schememeta}[1]{\inColor{IdentifierColor}{#1}}
\newcommand{\schememod}[1]{\inColor{black}{#1}}
\newcommand{\schemereader}[1]{\inColor{black}{#1}}
\newcommand{\schemevariablecol}[1]{\inColor{IdentifierColor}{#1}}
\newcommand{\schemevariable}[1]{{\schemevariablecol{\textsl{#1}}}}
\newcommand{\schemeerrorcol}[1]{\inColor{red}{#1}}
\newcommand{\schemeerror}[1]{{\schemeerrorcol{\textrm{\textit{#1}}}}}
\newcommand{\schemeopt}[1]{#1}
\newcommand{\textsub}[1]{$_{\hbox{\textsmaller{#1}}}$} \newcommand{\textsub}[1]{$_{\hbox{\textsmaller{#1}}}$}
\newcommand{\textsuper}[1]{$^{\hbox{\textsmaller{#1}}}$} \newcommand{\textsuper}[1]{$^{\hbox{\textsmaller{#1}}}$}
\newcommand{\intextcolor}[2]{\textcolor{#1}{#2}} \newcommand{\intextcolor}[2]{\textcolor{#1}{#2}}
\newcommand{\intextrgbcolor}[2]{\textcolor[rgb]{#1}{#2}} \newcommand{\intextrgbcolor}[2]{\textcolor[rgb]{#1}{#2}}
\newcommand{\incolorbox}[2]{{\fboxrule=0pt\fboxsep=0pt\colorbox{#1}{#2}}} \newcommand{\incolorbox}[2]{{\fboxrule=0pt\fboxsep=0pt\colorbox{#1}{#2}}}
\newcommand{\inrgbcolorbox}[2]{{\fboxrule=0pt\fboxsep=0pt\colorbox[rgb]{#1}{#2}}} \newcommand{\inrgbcolorbox}[2]{{\fboxrule=0pt\fboxsep=0pt\colorbox[rgb]{#1}{#2}}}
\newcommand{\schemeinput}[1]{\incolorbox{LightGray}{\schemeinputbg{#1}}}
\newcommand{\highlighted}[1]{\colorbox{PaleBlue}{\hspace{-0.5ex}\schemeinputbg{#1}\hspace{-0.5ex}}}
\newcommand{\plainlink}[1]{#1} \newcommand{\plainlink}[1]{#1}
\newcommand{\techoutside}[1]{#1} \newcommand{\techoutside}[1]{#1}
\newcommand{\techinside}[1]{#1} \newcommand{\techinside}[1]{#1}
@ -59,65 +48,75 @@
\newcommand{\indexlink}[1]{#1} \newcommand{\indexlink}[1]{#1}
\newcommand{\noborder}[1]{#1} \newcommand{\noborder}[1]{#1}
\newcommand{\imageleft}[1]{} % drop it \newcommand{\imageleft}[1]{} % drop it
\renewcommand{\smaller}[1]{\textsmaller{#1}} \newcommand{\Smaller}[1]{\textsmaller{#1}}
\newcommand{\Larger}[1]{\textlarger{#1}}
\newcommand{\planetName}[1]{PLane\hspace{-0.1ex}T} \newcommand{\planetName}[1]{PLane\hspace{-0.1ex}T}
\newcommand{\refpara}[1]{\marginpar{\raggedright \footnotesize #1}}
\newenvironment{refcolumn}{}{}
\newenvironment{refcontent}{}{}
\newcommand{\titleAndEmptyVersion}[2]{\title{#1}\maketitle}
\newcommand{\titleAndVersion}[2]{\title{#1\\{\normalsize Version #2}}\maketitle}
\newcommand{\sectionNewpage}{\newpage}
\newcommand{\preDoc}{\sloppy}
\newcommand{\postDoc}{}
\newcommand{\slant}[1]{{\textsl{#1}}} \newcommand{\slant}[1]{{\textsl{#1}}}
\newenvironment{leftindent}{\begin{quote}}{\end{quote}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\newenvironment{insetpara}{\begin{quote}}{\end{quote}} % Tables
\newcommand{\bibentry}[1]{\parbox[t]{0.8\linewidth}{#1}} % The `stabular' environment seems to be the lesser of evils among
% page-breaking table environments:
% stabular seems to be the lesser of all page-breaking table evironments
\newenvironment{bigtabular}{\begin{stabular}}{\end{stabular}} \newenvironment{bigtabular}{\begin{stabular}}{\end{stabular}}
% used to keep the horizontal line for a definition on the same page: % Used to keep the horizontal line for a definition on the same page:
\newcommand{\SEndFirstHead}[0]{ \nopagebreak \\ } \newcommand{\SEndFirstHead}[0]{ \nopagebreak \\ }
% attempts to correct weirdness when a table is the first thing in % Corrects weirdness when a table is the first thing in
% an itemization: % an itemization:
\newcommand{\bigtableinlinecorrect}[0]{~ \newcommand{\bigtableinlinecorrect}[0]{~
\vspace{-\baselineskip}\vspace{\parskip}} \vspace{-\baselineskip}\vspace{\parskip}}
% used to indent the table correctly in an itemization, since that's % Used to indent the table correctly in an itemization, since that's
% one of the things stabular gets wrong % one of the things stabular gets wrong:
\newlength{\stabLeft} \newlength{\stabLeft}
\newcommand{\bigtableleftpad}{\hspace{\stabLeft}} \newcommand{\bigtableleftpad}{\hspace{\stabLeft}}
\newcommand{\atItemizeStart}[0]{\addtolength{\stabLeft}{\labelsep} \newcommand{\atItemizeStart}[0]{\addtolength{\stabLeft}{\labelsep}
\addtolength{\stabLeft}{\labelwidth}} \addtolength{\stabLeft}{\labelwidth}}
% For a single-column table in simple environments, it's better to
% use the `list' environment instead of `stabular'.
\newenvironment{SingleColumn}{\begin{list}{}{\topsep=0pt\partopsep=0pt% \newenvironment{SingleColumn}{\begin{list}{}{\topsep=0pt\partopsep=0pt%
\listparindent=0pt\itemindent=0pt\labelwidth=0pt\leftmargin=0pt\rightmargin=0pt% \listparindent=0pt\itemindent=0pt\labelwidth=0pt\leftmargin=0pt\rightmargin=0pt%
\itemsep=0pt\parsep=0pt}\item}{\end{list}} \itemsep=0pt\parsep=0pt}\item}{\end{list}}
\newenvironment{schemeblock}{}{} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\newenvironment{defmodule}{}{} % Etc.
\newenvironment{prototype}{}{}
\newenvironment{argcontract}{}{}
\newenvironment{together}{}{}
\newenvironment{SBibliography}{}{}
% Default style for a nested flow:
\newenvironment{Subflow}{\begin{list}{}{\topsep=0pt\partopsep=0pt%
\listparindent=0pt\itemindent=0pt\labelwidth=0pt\leftmargin=0pt\rightmargin=0pt%
\itemsep=0pt}\item}{\end{list}}
% The 'inset neested-flow style uses the `quote' environment
% The 'compact itemization style:
\newenvironment{compact}{\begin{itemize}}{\end{itemize}} \newenvironment{compact}{\begin{itemize}}{\end{itemize}}
\newcommand{\compactItem}[1]{\item #1} \newcommand{\compactItem}[1]{\item #1}
\newcommand{\SecRef}[2]{\S#1 ``#2''} % The nested-flow style for `centerline':
\newenvironment{SCentered}{\begin{trivlist}\item \centering}{\end{trivlist}}
% The \refpara command corresponds to `margin-note'. The
% refcolumn and refcontent environments also wrap the note,
% because they simplify the CSS side.
\newcommand{\refpara}[1]{\marginpar{\raggedright \footnotesize #1}}
\newenvironment{refcolumn}{}{}
\newenvironment{refcontent}{}{}
% Macros used by `title' and `author':
\newcommand{\titleAndVersionAndAuthors}[3]{\title{#1\\{\normalsize Version #2}}\author{#3}\maketitle}
\newcommand{\titleAndVersionAndEmptyAuthors}[3]{\title{#1\\{\normalsize Version #2}}#3\maketitle}
\newcommand{\titleAndEmptyVersionAndAuthors}[3]{\title{#1}\author{#3}\maketitle}
\newcommand{\titleAndEmptyVersionAndEmptyAuthors}[3]{\title{#1}\maketitle}
\newcommand{\SAuthor}[1]{#1}
\newcommand{\SAuthorSep}[1]{\qquad}
% Used for parts with the 'hidden style variant:
\newcommand{\sectionhidden}[1]{\section{#1}} \newcommand{\sectionhidden}[1]{\section{#1}}
\newcommand{\subsectionhidden}[1]{\subsection{#1}} \newcommand{\subsectionhidden}[1]{\subsection{#1}}
\newcommand{\subsubsectionhidden}[1]{\subsubsection{#1}} \newcommand{\subsubsectionhidden}[1]{\subsubsection{#1}}
\newenvironment{SCentered}{\begin{trivlist}\item \centering}{\end{trivlist}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Scribble then generates the following: % Scribble then generates the following:
% %

109
collects/scribble/sigplan.ss Normal file
View File

@ -0,0 +1,109 @@
#lang scheme/base
(require setup/main-collects
scribble/core
scribble/base
scribble/decode
scribble/html-variants
scribble/latex-variants
(for-syntax scheme/base))
(provide preprint
abstract include-abstract
authorinfo
conferenceinfo copyrightyear copyrightdata
category terms keywords)
(define-syntax (preprint stx)
(raise-syntax-error #f
"option must appear on the same line as `#lang scribble/sigplan'"
stx))
(define sigplan-extras
(let ([abs (lambda (s)
(path->main-collects-relative
(build-path (collection-path "scribble") "sigplan" s)))])
(list
(make-css-addition (abs "sigplan.css"))
(make-tex-addition (abs "sigplan.tex")))))
;; ----------------------------------------
;; Abstracts:
(define abstract-style (make-style "abstract" sigplan-extras))
(define (abstract . strs)
(make-nested-flow
abstract-style
(decode-flow strs)))
(define (extract-abstract p)
(unless (part? p)
(error 'include-abstract "doc binding is not a part: ~e" p))
(unless (null? (part-parts p))
(error 'include-abstract "abstract part has sub-parts: ~e" (part-parts p)))
(when (part-title-content p)
(error 'include-abstract "abstract part has title content: ~e" (part-title-content p)))
(part-blocks p))
(define-syntax-rule (include-abstract mp)
(begin
(require (only-in mp [doc abstract-doc]))
(make-nested-flow abstract-style (extract-abstract abstract-doc))))
;; ----------------------------------------
;; Authors and conference info:
(define (authorinfo name affiliation e-mail)
(author
(make-multiarg-element
(make-style "SAuthorinfo"sigplan-extras)
(list
(make-element #f (decode-content (list name)))
(make-element (make-style "SAuthorPlace" sigplan-extras)
(decode-content (list affiliation)))
(make-element (make-style "SAuthorEmail" sigplan-extras)
(decode-content (list e-mail)))))))
(define (conferenceinfo what where)
(make-paragraph
(make-style 'pretitle null)
(make-multiarg-element
(make-style "SConferenceInfo" sigplan-extras)
(list
(make-element #f (decode-content (list what)))
(make-element #f (decode-content (list where)))))))
(define (copyrightyear . when)
(make-paragraph
(make-style 'pretitle null)
(make-element
(make-style "SCopyrightYear" sigplan-extras)
(decode-content when))))
(define (copyrightdata . what)
(make-paragraph
(make-style 'pretitle null)
(make-element
(make-style "SCopyrightData" sigplan-extras)
(decode-content what))))
;; ----------------------------------------
;; Categories, terms, and keywords:
(define (category sec title sub [more #f])
(make-multiarg-element
(make-style (format "SCategory~a" (if more "Plus" "")) sigplan-extras)
(append
(list
(make-element #f (decode-content (list sec)))
(make-element #f (decode-content (list title)))
(make-element #f (decode-content (list sub))))
(if more
(list (make-element #f (decode-content (list more))))
null))))
(define (terms . str)
(make-element (make-style "STerms" sigplan-extras) (decode-content str)))
(define (keywords . str)
(make-element (make-style "SKeywords" sigplan-extras) (decode-content str)))

41
collects/scribble/sigplan/lang.ss Normal file
View File

@ -0,0 +1,41 @@
#lang scheme/base
(require scribble/doclang
scribble/core
scribble/base
scribble/decode
scribble/sigplan
"../private/defaults.ss"
(for-syntax scheme/base))
(provide (except-out (all-from-out scribble/doclang) #%module-begin)
(all-from-out scribble/sigplan)
(all-from-out scribble/base)
(rename-out [module-begin #%module-begin]))
(define-syntax (module-begin stx)
(syntax-case* stx (preprint) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[(_ id ws . body)
;; Skip intraline whitespace to find options:
(and (string? (syntax-e #'ws))
(regexp-match? #rx"^ *$" (syntax-e #'ws)))
#'(module-begin id . body)]
[(_ id preprint . body)
#'(#%module-begin id (post-process #t) () . body)]
[(_ id . body)
#'(#%module-begin id (post-process #f) () . body)]))
(define ((post-process preprint?) doc)
(add-sigplan-styles
(add-defaults doc
(string->bytes/utf-8
(format "\\documentclass~a{sigplanconf}\n\\usepackage{times}\n\\usepackage{qcourier}\n"
(if preprint? "[preprint]" "")))
(scribble-file "sigplan/style.tex")
(list (scribble-file "sigplan/sigplanconf.cls"))
#f)))
(define (add-sigplan-styles doc)
;; Ensure that "sigplan.tex" is used, since "style.tex"
;; re-defines commands.
(struct-copy part doc [to-collect
(cons (terms)
(part-to-collect doc))]))

10
collects/scribble/sigplan/lang/reader.ss Normal file
View File

@ -0,0 +1,10 @@
#lang s-exp syntax/module-reader
scribble/sigplan/lang
#:read scribble:read-inside
#:read-syntax scribble:read-syntax-inside
#:whole-body-readers? #t
#:wrapper1 (lambda (t) (cons 'doc (t)))
(require (prefix-in scribble: "../../reader.ss"))

8
collects/scribble/sigplan/sigplan.css Normal file
View File

@ -0,0 +1,8 @@
/* Support for styles in scribble/sigplan */
.SAuthorPlace, .SAuthorEmail,
.SConferenceInfo, .SCopyrightYear, .SCopyrightData,
.SCategory, .SCategoryPlus, .STerms, .SKeywords {
display: none;
}

18
collects/scribble/sigplan/sigplan.tex Normal file
View File

@ -0,0 +1,18 @@
% Support for styles in scribble/sigplan
% These are replaced by scribble/sigplan/style.tex,
% which is used in combination with sigplanconf.sty
\newcommand{\SAuthorinfo}[3]{#1}
\newcommand{\SAuthorPlace}[1]{#1}
\newcommand{\SAuthorEmail}[1]{#1}
\newcommand{\SConferenceInfo}[2]{}
\newcommand{\SCopyrightYear}[1]{}
\newcommand{\SCopyrightData}[1]{}
\newcommand{\SCategory}[3]{}
\newcommand{\SCategoryPlus}[4]{}
\newcommand{\STerms}[1]{}
\newcommand{\SKeywords}[1]{}

1222
collects/scribble/sigplan/sigplanconf.cls Normal file
View File

File diff suppressed because it is too large Load Diff

20
collects/scribble/sigplan/style.tex Normal file
View File

@ -0,0 +1,20 @@
\renewcommand{\titleAndVersionAndAuthors}[3]{\title{#1}#3\maketitle}
\renewcommand{\titleAndEmptyVersionAndAuthors}[3]{\titleAndVersionAndAuthors{#1}{#2}{#3}}
\renewcommand{\titleAndVersionAndEmptyAuthors}[3]{\title{#1}\authorinfo{Anonymous}{}{}\maketitle}
\renewcommand{\titleAndEmptyVersionAndEmptyAuthors}[3]{\titleAndVersionAndEmptyAuthors{#1}{#2}{#3}}
% Disable plain `author', enable `authorinfo:'
\renewcommand{\SAuthor}[1]{#1}
\renewcommand{\SAuthorinfo}[3]{\authorinfo{#1}{#2}{#3}}
\renewcommand{\SAuthorSep}[1]{}
\renewcommand{\SConferenceInfo}[2]{\conferenceinfo{#1}{#2}}
\renewcommand{\SCopyrightYear}[1]{\copyrightyear{#1}}
\renewcommand{\SCopyrightData}[1]{\copyrightdata{#1}}
\renewcommand{\SCategory}[3]{\category{#1}{#2}{#3}}
\renewcommand{\SCategoryPlus}[4]{\category{#1}{#2}{#3}[#4]}
\renewcommand{\STerms}[1]{\terms{#1}}
\renewcommand{\SKeywords}[1]{\keywords{#1}}

837
collects/scribble/struct.ss
View File

@ -1,544 +1,401 @@
#lang scheme/base #lang scheme/base
(require scheme/serialize (require (rename-in (except-in "core.ss"
target-url struct:target-url target-url? target-url-addr
deserialize-info:target-url-v0)
[make-target-url core:make-target-url])
"private/provide-structs.ss"
"html-variants.ss"
scheme/provide-syntax
scheme/struct-info
scheme/contract scheme/contract
(for-syntax scheme/base)) (for-syntax scheme/base))
;; ---------------------------------------- (define-provide-syntax (compat**-out stx)
(syntax-case stx ()
[(_ struct-out o)
(let ([id (syntax-case #'o ()
[(id (field-id ...)) #'id]
[id #'id])])
(with-syntax ([make-id (datum->syntax id
(string->symbol (format "make-~a" (syntax-e id)))
id)]
[make-id/compat (datum->syntax id
(string->symbol (format "make-~a/compat" (syntax-e id)))
id)])
#'(combine-out
(except-out (struct-out o) make-id)
(rename-out [make-id/compat make-id]))))]
[(_ struct-out o ...) #'(combine-out (compat**-out struct-out o) ...)]))
(define-struct collect-info (ht ext-ht parts tags gen-prefix relatives parents)) (define-provide-syntax (compat-out stx)
(define-struct resolve-info (ci delays undef searches)) (syntax-case stx ()
[(_ . outs) #'(compat**-out struct-out . outs)]))
(define (part-collected-info part ri) (define-provide-syntax (compat*-out stx)
(hash-ref (collect-info-parts (resolve-info-ci ri)) (syntax-case stx ()
part)) [(_ . outs) #'(compat**-out struct*-out . outs)]))
(define (collect-put! ci key val) (define-provide-syntax (struct*-out stx)
(let ([ht (collect-info-ht ci)]) (syntax-case stx ()
(let ([old-val (hash-ref ht key #f)]) [(_ [id (field-id ...)])
(when old-val (with-syntax ([id? (datum->syntax #'id
(fprintf (current-error-port) (string->symbol (format "~a?" (syntax-e #'id)))
"WARNING: collected information for key multiple times: ~e; values: ~e ~e\n" #'id)]
key old-val val)) [struct:id (datum->syntax #'id
(hash-set! ht key val)))) (string->symbol (format "struct:~a" (syntax-e #'id)))
#'id)]
(define (resolve-get/where part ri key) [make-id (datum->syntax #'id
(let ([key (tag-key key ri)]) (string->symbol (format "make-~a" (syntax-e #'id)))
(let ([v (hash-ref (if part #'id)]
(collected-info-info (part-collected-info part ri)) [(sel-id ...)
(collect-info-ht (resolve-info-ci ri))) (map (lambda (field-id)
key (datum->syntax field-id
#f)]) (string->symbol (format "~a-~a" (syntax-e #'id) (syntax-e field-id)))
(cond field-id))
[v (values v #f)] (syntax->list #'(field-id ...)))])
[part (resolve-get/where #'(combine-out
(collected-info-parent (part-collected-info part ri)) id struct:id make-id id? sel-id ...))]
ri key)] [(_ [id (field-id ...)]...)
[else #'(combine-out (struct*-out [id (field-id ...)]) ...)]))
(values (hash-ref (collect-info-ext-ht (resolve-info-ci ri)) key #f)
#t)]))))
(define (resolve-get/ext? part ri key)
(let-values ([(v ext?) (resolve-get/where part ri key)])
(when ext?
(hash-set! (resolve-info-undef ri) (tag-key key ri) #t))
(values v ext?)))
(define (resolve-get part ri key)
(let-values ([(v ext?) (resolve-get/ext? part ri key)])
v))
(define (resolve-get/tentative part ri key)
(let-values ([(v ext?) (resolve-get/where part ri key)])
v))
(define (resolve-search search-key part ri key)
(let ([s-ht (hash-ref (resolve-info-searches ri)
search-key
(lambda ()
(let ([s-ht (make-hash)])
(hash-set! (resolve-info-searches ri)
search-key s-ht)
s-ht)))])
(hash-set! s-ht key #t))
(resolve-get part ri key))
(define (resolve-get-keys part ri key-pred)
(let ([l null])
(hash-for-each
(collected-info-info (part-collected-info part ri))
(lambda (k v) (when (key-pred k) (set! l (cons k l)))))
l))
(provide (struct-out collect-info) (provide (struct-out collect-info)
(struct-out resolve-info)) (struct-out resolve-info)
tag? block?
;; ---------------------------------------- make-flow flow? flow-paragraphs
(provide provide-structs) (except-out (compat-out part) part-title-content)
(rename-out [part-blocks part-flow]
[part-title-content/compat part-title-content])
make-versioned-part versioned-part?
make-unnumbered-part unnumbered-part?
(define-syntax (provide-structs stx) (except-out (compat-out paragraph) paragraph-content)
(syntax-case stx () (rename-out [paragraph-content/compat paragraph-content])
[(_ (id ([field ct] ...)) ...) make-styled-paragraph
#`(begin (rename-out [paragraph? styled-paragraph?]
(define-serializable-struct id (field ...)) ... [paragraph-style styled-paragraph-style])
(provide/contract make-omitable-paragraph omitable-paragraph?
#,@(let ([ids (syntax->list #'(id ...))]
[fields+cts (syntax->list #'(([field ct] ...) ...))])
(define (get-fields super-id)
(ormap (lambda (id fields+cts)
(if (identifier? id)
(and (free-identifier=? id super-id)
fields+cts)
(syntax-case id ()
[(my-id next-id)
(free-identifier=? #'my-id super-id)
#`[#,@(get-fields #'next-id)
#,@fields+cts]]
[_else #f])))
ids fields+cts))
(map (lambda (id fields+cts)
(if (identifier? id)
#`[struct #,id #,fields+cts]
(syntax-case id ()
[(id super)
#`[struct id (#,@(get-fields #'super)
#,@fields+cts)]])))
ids
fields+cts))))]))
(provide tag?) (compat-out table)
(define (tag? s) table-flowss
(and (pair? s) make-auxiliary-table auxiliary-table?
(symbol? (car s))
(pair? (cdr s))
(or (string? (cadr s))
(generated-tag? (cadr s))
(and (pair? (cadr s))
(list? (cadr s))))
(null? (cddr s))))
(provide block?) (struct-out delayed-block)
(define (block? p)
(or (paragraph? p)
(table? p)
(itemization? p)
(blockquote? p)
(compound-paragraph? p)
(delayed-block? p)))
(define (string-without-newline? s) (compat-out itemization)
(and (string? s) (rename-out [itemization-blockss itemization-flows]
(not (regexp-match? #rx"\n" s)))) [itemization? styled-itemization?]
[itemization-style styled-itemization-style])
make-styled-itemization
make-blockquote
(compat-out compound-paragraph)
(except-out (compat-out element) element? element-style element-content)
(rename-out [element?/compat element?]
[element-style/compat element-style]
[element-content/compat element-content])
(except-out (compat*-out [toc-element (toc-content)])
toc-element-toc-content)
(rename-out [toc-element-toc-content/compat toc-element-toc-content])
(compat*-out [target-element (tag)]
[toc-target-element ()]
[page-target-element ()]
[redirect-target-element (alt-path alt-anchor)]
[link-element (tag)]
[index-element (tag plain-seq entry-seq desc)])
make-aux-element aux-element?
make-hover-element hover-element? hover-element-text
make-script-element script-element? script-element-type script-element-script
(struct-out collected-info)
(struct-out delayed-element)
; delayed-element-content delayed-block-blocks current-serialize-resolve-info
(struct-out part-relative-element)
; part-relative-element-content collect-info-parents
(struct-out delayed-index-desc)
(struct*-out [collect-element (collect)])
(struct*-out [render-element (render)])
(struct-out generated-tag)
; generate-tag tag-key current-tag-prefixes add-current-tag-prefix
content->string
(rename-out [content->string element->string]
[content-width element-width])
; strip-aux
block-width
info-key? part-collected-info collect-put!
resolve-get resolve-get/tentative resolve-get/ext? resolve-search resolve-get-keys)
(provide-structs (provide-structs
[part ([tag-prefix (or/c false/c string?)]
[tags (listof tag?)]
[title-content (or/c false/c list?)]
[style any/c]
[to-collect list?]
[flow flow?]
[parts (listof part?)])]
[(unnumbered-part part) ()]
[(versioned-part part) ([version (or/c string? false/c)])]
[flow ([paragraphs (listof block?)])]
[paragraph ([content list?])]
[(styled-paragraph paragraph) ([style any/c])]
[(omitable-paragraph paragraph) ()]
[table ([style any/c]
[flowss (listof (listof (or/c flow? (one-of/c 'cont))))])]
[(auxiliary-table table) ()]
[delayed-block ([resolve (any/c part? resolve-info? . -> . block?)])]
[itemization ([flows (listof flow?)])]
[(styled-itemization itemization) ([style any/c])]
[blockquote ([style any/c]
[paragraphs (listof block?)])]
[compound-paragraph ([style any/c]
[blocks (listof block?)])]
;; content = list of elements
[element ([style any/c]
[content list?])]
[(toc-element element) ([toc-content list?])]
[(target-element element) ([tag tag?])]
[(toc-target-element target-element) ()]
[(page-target-element target-element) ()]
[(redirect-target-element target-element) ([alt-path path-string?]
[alt-anchor string?])]
[(link-element element) ([tag tag?])]
[(index-element element) ([tag tag?]
[plain-seq (and/c pair? (listof string-without-newline?))]
[entry-seq list?]
[desc any/c])]
[(aux-element element) ()]
[(hover-element element) ([text string?])]
[(script-element element) ([type string?]
[script (or/c path-string? (listof string?))])]
;; specific renders support other elements, especially strings
[with-attributes ([style any/c] [with-attributes ([style any/c]
[assoc (listof (cons/c symbol? string?))])] [assoc (listof (cons/c symbol? string?))])]
[collected-info ([number (listof (or/c false/c integer?))]
[parent (or/c false/c part?)]
[info any/c])]
[target-url ([addr path-string?] [style any/c])]
[url-anchor ([name string?])]
[image-file ([path (or/c path-string? [image-file ([path (or/c path-string?
(cons/c (one-of/c 'collects) (cons/c (one-of/c 'collects)
(listof bytes?)))] (listof bytes?)))]
[scale real?])]) [scale real?])]
[target-url ([addr path-string?] [style any/c])])
;; ---------------------------------------- (define (make-flow l) l)
(define (flow? l) (and (list? l) (andmap block? l)))
(define (flow-paragraphs l) l)
;; Delayed element has special serialization support: (define (list->content l)
(define-struct delayed-element (resolve sizer plain) (if (and (pair? l) (null? (cdr l)))
#:property (car l)
prop:serializable l))
(make-serialize-info
(lambda (d)
(let ([ri (current-serialize-resolve-info)])
(unless ri
(error 'serialize-delayed-element
"current-serialize-resolve-info not set"))
(with-handlers ([exn:fail:contract?
(lambda (exn)
(error 'serialize-delayed-element
"serialization failed (wrong resolve info? delayed element never rendered?); ~a"
(exn-message exn)))])
(vector
(let ([l (delayed-element-content d ri)])
(if (and (pair? l) (null? (cdr l)))
(car l)
(make-element #f l)))))))
#'deserialize-delayed-element
#f
(or (current-load-relative-directory) (current-directory))))
(provide/contract (define (content->list v)
(struct delayed-element ([resolve (any/c part? resolve-info? . -> . list?)] (if (list? v)
[sizer (-> any)] v
[plain (-> any)]))) (list v)))
(provide deserialize-delayed-element) (define (make-part/compat tag-prefix tags title-content orig-style to-collect flow parts)
(define deserialize-delayed-element (make-part tag-prefix
(make-deserialize-info values values)) tags
(list->content title-content)
(convert-style orig-style)
to-collect
(flow-paragraphs flow)
parts))
(provide delayed-element-content) (define (part-title-content/compat p)
(define (delayed-element-content e ri) (list (part-title-content p)))
(hash-ref (resolve-info-delays ri) e))
(provide delayed-block-blocks) (define (make-versioned-part tag-prefix tags title-content orig-style to-collect flow parts version)
(define (delayed-block-blocks p ri) (make-part tag-prefix
(hash-ref (resolve-info-delays ri) p)) tags
(list->content title-content)
(let ([s (convert-style orig-style)])
(make-style (style-name s)
(cons
(make-document-version version)
(style-variants s))))
to-collect
(flow-paragraphs flow)
parts))
(define (versioned-part? p)
(and (part? p) (ormap document-version? (style-variants (part-style p)))))
(provide current-serialize-resolve-info) (define (make-unnumbered-part tag-prefix tags title-content orig-style to-collect flow parts)
(define current-serialize-resolve-info (make-parameter #f)) (make-part tag-prefix
tags
(list->content title-content)
(let ([s (convert-style orig-style)])
(make-style (style-name s)
(cons 'unnumbered (style-variants s))))
to-collect
(flow-paragraphs flow)
parts))
(define (unnumbered-part? p)
(and (part? p) (memq 'unnumbered (style-variants (part-style p)))))
;; ---------------------------------------- (define (make-paragraph/compat content)
(make-paragraph plain (list->content content)))
(define (paragraph-content/compat p)
(content->list (paragraph-content p)))
(define (make-styled-paragraph content style)
(make-paragraph (convert-style style) (list->content content)))
;; part-relative element has special serialization support: (define (make-omitable-paragraph content)
(define-struct part-relative-element (collect sizer plain) (make-paragraph (make-style #f '(omitable)) (list->content content)))
#:property (define (omitable-paragraph? p)
prop:serializable (and (paragraph? p) (memq 'omitable (style-variants (paragraph-style p)))))
(make-serialize-info
(lambda (d)
(let ([ri (current-serialize-resolve-info)])
(unless ri
(error 'serialize-part-relative-element
"current-serialize-resolve-info not set"))
(with-handlers ([exn:fail:contract?
(lambda (exn)
(error 'serialize-part-relative-element
"serialization failed (wrong resolve info? part-relative element never rendered?); ~a"
(exn-message exn)))])
(vector
(make-element #f (part-relative-element-content d ri))))))
#'deserialize-part-relative-element
#f
(or (current-load-relative-directory) (current-directory))))
(provide/contract (define (make-table/compat style cellss)
(struct part-relative-element ([collect (collect-info? . -> . list?)] (make-table (convert-style style)
[sizer (-> any)] (map (lambda (cells)
[plain (-> any)]))) (map (lambda (cell)
(cond
[(eq? cell 'cont) 'cont]
[(= 1 (length cell)) (car cell)]
[else (make-nested-flow plain cell)]))
cells))
cellss)))
(define (table-flowss t)
(map (lambda (row) (map (lambda (c) (make-flow (list c))) row))
(table-blockss t)))
(provide deserialize-part-relative-element) (define (make-auxiliary-table style cells)
(define deserialize-part-relative-element (let ([t (make-table/compat style cells)])
(make-deserialize-info values values)) (make-table (make-style (style-name (table-style t))
(cons 'aux
(style-variants (table-style t))))
(table-blockss t))))
(provide part-relative-element-content) (define (auxiliary-table? t)
(define (part-relative-element-content e ci/ri) (ormap (lambda (v) (eq? v 'aux) (style-variants (table-style t)))))
(hash-ref (collect-info-relatives
(if (resolve-info? ci/ri) (resolve-info-ci ci/ri) ci/ri))
e))
(provide collect-info-parents) (define (make-itemization/compat flows)
(make-itemization plain flows))
(define (make-styled-itemization style flows)
(make-itemization (convert-style style) flows))
;; ---------------------------------------- (define (make-blockquote style blocks)
(make-nested-flow (convert-style (or style 'inset)) blocks))
;; Delayed index entry also has special serialization support. (define (make-compound-paragraph/compat style blocks)
;; It uses the same delay -> value table as delayed-element (make-compound-paragraph (convert-style style) blocks))
(define-struct delayed-index-desc (resolve)
#:mutable
#:property
prop:serializable
(make-serialize-info
(lambda (d)
(let ([ri (current-serialize-resolve-info)])
(unless ri
(error 'serialize-delayed-index-desc
"current-serialize-resolve-info not set"))
(with-handlers ([exn:fail:contract?
(lambda (exn)
(error 'serialize-index-desc
"serialization failed (wrong resolve info?); ~a"
(exn-message exn)))])
(vector
(delayed-element-content d ri)))))
#'deserialize-delayed-index-desc
#f
(or (current-load-relative-directory) (current-directory))))
(provide/contract (define (element-style-name s)
(struct delayed-index-desc ([resolve (any/c part? resolve-info? . -> . any)]))) (if (style? s)
(style-name s)
s))
(define (element-style-variants s)
(if (style? s)
(style-variants s)
null))
(provide deserialize-delayed-index-desc) (define (add-element-variant v e)
(define deserialize-delayed-index-desc (make-element (make-style (element-style-name (element-style e))
(make-deserialize-info values values)) (cons v
(element-style-variants (element-style e))))
(element-content e)))
(define (check-element-style e pred)
(ormap pred (style-variants (element-style e))))
;; ---------------------------------------- (define (handle-image-style ctr style . args)
(if (image-file? style)
(make-image-element #f (list (apply ctr #f args))
(image-file-path style)
null
(image-file-scale style))
(apply ctr (convert-element-style style) args)))
(define-struct (collect-element element) (collect) (define (convert-element-style style)
#:mutable
#:property
prop:serializable
(make-serialize-info
(lambda (d)
(vector (make-element
(element-style d)
(element-content 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 (render-element element) (render)
#:property
prop:serializable
(make-serialize-info
(lambda (d)
(vector (make-element
(element-style d)
(element-content d))))
#'deserialize-render-element
#f
(or (current-load-relative-directory) (current-directory))))
(provide deserialize-render-element)
(define deserialize-render-element
(make-deserialize-info values values))
(provide/contract
[struct render-element ([style any/c]
[content list?]
[render (any/c part? resolve-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-ref (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-out generated-tag))
(provide deserialize-generated-tag)
(define deserialize-generated-tag
(make-deserialize-info values values))
(provide generate-tag tag-key
current-tag-prefixes
add-current-tag-prefix)
(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-ref tags t #f)
(let ([key (list* 'gentag
(hash-count tags)
(collect-info-gen-prefix ci))])
(hash-set! tags t key)
key)))))
tg))
(define (tag-key tg ri)
(if (generated-tag? (cadr tg))
(list (car tg)
(hash-ref (collect-info-tags (resolve-info-ci ri)) (cadr tg)))
tg))
(define current-tag-prefixes (make-parameter null))
(define (add-current-tag-prefix t)
(let ([l (current-tag-prefixes)])
(if (null? l)
t
(cons (car t) (append l (cdr t))))))
;; ----------------------------------------
(provide content->string
element->string
strip-aux)
(define content->string
(case-lambda
[(c) (c->s c element->string)]
[(c renderer sec ri)
(c->s c (lambda (e) (element->string e renderer sec ri)))]))
(define (c->s c do-elem)
(apply string-append (map do-elem c)))
(define element->string
(case-lambda
[(c)
(cond
[(element? c) (content->string (element-content c))]
[(part-relative-element? c) (element->string ((part-relative-element-plain c)))]
[(delayed-element? c) (element->string ((delayed-element-plain c)))]
[(string? c) c]
[else (case c
[(mdash) "---"]
[(ndash) "--"]
[(ldquo rdquo) "\""]
[(rsquo) "'"]
[(rarr) "->"]
[(lang) "<"]
[(rang) ">"]
[else (format "~s" c)])])]
[(c renderer sec ri)
(cond
[(and (link-element? c)
(null? (element-content c)))
(let ([dest (resolve-get sec ri (link-element-tag c))])
;; FIXME: this is specific to renderer
(if dest
(content->string (strip-aux
(if (pair? dest) (cadr dest) (vector-ref dest 1)))
renderer sec ri)
"???"))]
[(element? c) (content->string (element-content c) renderer sec ri)]
[(delayed-element? c)
(content->string (delayed-element-content c ri) renderer sec ri)]
[(part-relative-element? c)
(content->string (part-relative-element-content c ri) renderer sec ri)]
[else (element->string c)])]))
(define (strip-aux content)
(cond (cond
[(null? content) null] [(not style) style]
[(aux-element? (car content)) (strip-aux (cdr content))] [(string? style) style]
[else (cons (car content) (strip-aux (cdr content)))])) [(symbol? style) style]
[else (convert-style style)]))
;; ---------------------------------------- (define (element?/compat e)
(or (element? e) (and (list? e) (content? e))))
(provide block-width (define (element-content/compat e)
element-width)
(define (element-width s)
(cond (cond
[(string? s) (string-length s)] [(element? e) (content->list (element-content e))]
[(element? s) (apply + (map element-width (element-content s)))] [else e]))
[(delayed-element? s) (element-width ((delayed-element-sizer s)))] (define (element-style/compat e)
[(part-relative-element? s) (element-width ((part-relative-element-sizer s)))]
[else 1]))
(define (paragraph-width s)
(apply + (map element-width (paragraph-content s))))
(define (flow-width f)
(apply max 0 (map block-width (flow-paragraphs f))))
(define (block-width p)
(cond (cond
[(paragraph? p) (paragraph-width p)] [(element? e) (element-style e)]
[(table? p) (table-width p)] [else #f]))
[(itemization? p) (itemization-width p)]
[(blockquote? p) (blockquote-width p)]
[(compound-paragraph? p) (compound-paragraph-width p)]
[(delayed-block? p) 1]))
(define (table-width p) (define (make-element/compat style content)
(let ([flowss (table-flowss p)]) (handle-image-style make-element style (list->content content)))
(if (null? flowss) (define (make-toc-element/compat style content toc-content)
0 (handle-image-style make-toc-element style (list->content content) (list->content toc-content)))
(let loop ([flowss flowss]) (define (toc-element-toc-content/compat e)
(if (null? (car flowss)) (content->list (toc-element-toc-content e)))
0 (define (make-target-element/compat style content tag)
(+ (apply max 0 (map flow-width (map car flowss))) (handle-image-style make-target-element style (list->content content) tag))
(loop (map cdr flowss)))))))) (define (make-toc-target-element/compat style content tag)
(handle-image-style make-toc-target-element style (list->content content) tag))
(define (make-page-target-element/compat style content tag)
(handle-image-style make-page-target-element style (list->content content) tag))
(define (make-redirect-target-element/compat style content tag alt-path alt-anchor)
(handle-image-style make-redirect-target-element style (list->content content) tag alt-path alt-anchor))
(define (make-link-element/compat style content tag)
(handle-image-style make-link-element style (list->content content) tag))
(define (make-index-element/compat style content tag plain-seq etry-seq desc)
(handle-image-style make-index-element style (list->content content) tag plain-seq etry-seq desc))
(define (itemization-width p) (define (make-aux-element style content)
(apply max 0 (map flow-width (itemization-flows p)))) (add-element-variant 'aux (make-element/compat style content)))
(define (aux-element? e)
(check-element-style e (lambda (v) (eq? v 'aux))))
(define (blockquote-width p) (define (make-hover-element style content text)
(+ 4 (apply max 0 (map block-width (blockquote-paragraphs p))))) (add-element-variant (make-hover-variant text)
(make-element/compat style content)))
(define (hover-element? e)
(check-element-style e hover-variant?))
(define (hover-element-text e)
(ormap (lambda (v)
(and (hover-variant? v) (hover-variant-text e)))
(style-variants (element-style e))))
(define (compound-paragraph-width p) (define (make-script-element style content type script)
(apply max 0 (map block-width (compound-paragraph-blocks p)))) (add-element-variant (make-script-variant type script)
(make-element/compat style content)))
(define (script-element? e)
(check-element-style e script-variant?))
(define (script-element-type e)
(ormap (lambda (v)
(and (script-variant? v) (script-variant-type e)))
(style-variants (element-style e))))
(define (script-element-script e)
(ormap (lambda (v)
(and (script-variant? v) (script-variant-script e)))
(style-variants (element-style e))))
;; ---------------------------------------- ;; ----------------------------------------
(provide part-style?) (define (convert-style s)
(cond
(define (part-style? p s) [(not s) plain]
(let ([st (part-style p)]) [(style? s) s]
(or (eq? s st) [(string? s) (make-style s null)]
(and (list? st) (memq s st))))) [(symbol? s) (make-style s null)]
[(and (list? s) (andmap symbol? s)) (make-style #f s)]
;; ---------------------------------------- [(with-attributes? s) (let* ([wa (flatten-style s)]
[s (convert-style (with-attributes-style wa))])
(define (info-key? l) (make-style (style-name s)
(and (pair? l) (cons
(symbol? (car l)) (make-attributes (with-attributes-assoc wa))
(pair? (cdr l)))) (style-variants s))))]
[(target-url? s) (let ([s (convert-style (target-url-style s))])
(provide info-key?) (make-style (style-name s)
(provide/contract (cons
[part-collected-info (part? resolve-info? . -> . collected-info?)] (core:make-target-url (target-url-addr s))
[collect-put! (collect-info? info-key? any/c . -> . any)] (style-variants s))))]
[resolve-get ((or/c part? false/c) resolve-info? info-key? . -> . any)] [(image-file? s) (make-style #f null)]
[resolve-get/tentative ((or/c part? false/c) resolve-info? info-key? . -> . any)] [(and (list? s) (pair? s) (eq? (car s) 'color))
[resolve-get/ext? ((or/c part? false/c) resolve-info? info-key? . -> . any)] (make-style #f (list (make-color-variant
[resolve-search (any/c (or/c part? false/c) resolve-info? info-key? . -> . any)] (if (string? (cadr s)) (cadr s) (cdr s)))))]
[resolve-get-keys ((or/c part? false/c) resolve-info? (info-key? . -> . any/c) . -> . any/c)]) [(and (list? s) (pair? s) (eq? (car s) 'bg-color))
(make-style #f (list (make-background-color-variant
;; ---------------------------------------- (if (string? (cadr s)) (cadr s) (cdr s)))))]
[(and (pair? s)
(list? s)
(andmap (lambda (v) (and (pair? v)
(memq (car v) '(alignment valignment row-styles style))))
s))
(let ([gen-columns (lambda (sn a va)
(map (lambda (sn a va)
(make-style sn
(append (if a (list a) null)
(if va (list va) null))))
(cdr (or sn (map (lambda (x) #f) (or va a))))
(cdr (or a (map (lambda (x) #f) (or va sn))))
(cdr (or va (map (lambda (x) #f) (or a sn))))))])
(make-style (let ([s (assq 'style s)])
(and s (cadr s)))
(let ([a (assq 'alignment s)]
[va (assq 'valignment s)])
(if (or a va)
(list (make-table-columns (gen-columns #f a va)))
(let ([l (cdr (assq 'row-styles s))])
(list
(make-table-cells
(map (lambda (row)
(let ([sn (assq 'style row)]
[a (assq 'alignment row)]
[va (assq 'valignment row)])
(if (or sn a va)
(gen-columns sn a va)
(error 'convert-style "no row style found"))))
l))))))))]
[else (error 'convert-style "unrecognized style: ~e" s)]))
(define (flatten-style s) (define (flatten-style s)
(cond (cond
@ -568,5 +425,3 @@
(target-url-addr s) (target-url-addr s)
rest)))] rest)))]
[else s])) [else s]))
(provide flatten-style)

29
collects/scribble/text-render.ss
View File

@ -1,6 +1,6 @@
(module text-render mzscheme (module text-render mzscheme
(require "struct.ss" (require "core.ss"
mzlib/class) mzlib/class)
(provide render-mixin) (provide render-mixin)
@ -35,7 +35,7 @@
(part-title-content d)) (part-title-content d))
(newline)) (newline))
(newline) (newline)
(render-flow (part-flow d) d ht #f) (render-flow (part-blocks d) d ht #f)
(let loop ([pos 1] (let loop ([pos 1]
[secs (part-parts d)]) [secs (part-parts d)])
(unless (null? secs) (unless (null? secs)
@ -44,31 +44,30 @@
(loop (add1 pos) (cdr secs)))))) (loop (add1 pos) (cdr secs))))))
(define/override (render-flow f part ht starting-item?) (define/override (render-flow f part ht starting-item?)
(let ([f (flow-paragraphs f)]) (if (null? f)
(if (null? f) null
null (apply
(apply append
append (render-block (car f) part ht starting-item?)
(render-block (car f) part ht starting-item?) (map (lambda (p)
(map (lambda (p) (newline) (newline)
(newline) (newline) (render-block p part ht #f))
(render-block p part ht #f)) (cdr f)))))
(cdr f))))))
(define/override (render-table i part ht inline?) (define/override (render-table i part ht inline?)
(let ([flowss (table-flowss i)]) (let ([flowss (table-blockss i)])
(if (null? flowss) (if (null? flowss)
null null
(apply (apply
append append
(map (lambda (d) (unless (eq? d 'cont) (render-flow d part ht #f))) (car flowss)) (map (lambda (d) (unless (eq? d 'cont) (render-block d part ht #f))) (car flowss))
(map (lambda (flows) (map (lambda (flows)
(newline) (newline)
(map (lambda (d) (unless (eq? d 'cont) (render-flow d part ht #f))) flows)) (map (lambda (d) (unless (eq? d 'cont) (render-flow d part ht #f))) flows))
(cdr flowss)))))) (cdr flowss))))))
(define/override (render-itemization i part ht) (define/override (render-itemization i part ht)
(let ([flows (itemization-flows i)]) (let ([flows (itemization-blockss i)])
(if (null? flows) (if (null? flows)
null null
(apply append (apply append

3
collects/scribblings/drscheme/interface-essentials.scrbl
View File

@ -3,13 +3,14 @@
scribble/decode scribble/decode
scribble/eval scribble/eval
scribble/struct scribble/struct
scribble/scheme
(for-label htdp/convert (for-label htdp/convert
scheme/gui/base)) scheme/gui/base))
@(define (ioinputfont . s) @(define (ioinputfont . s)
(apply tt s)) (apply tt s))
@(define (iooutputfont . s) @(define (iooutputfont . s)
(make-element "schemestdout" (decode-content s))) (make-element output-color (decode-content s)))
@title[#:tag "interface-essentials" #:style 'toc]{Interface Essentials} @title[#:tag "interface-essentials" #:style 'toc]{Interface Essentials}

5
collects/scribblings/guide/guide.scrbl
View File

@ -1,6 +1,5 @@
#lang scribble/doc #lang scribble/manual
@(require scribble/manual @(require scribble/eval
scribble/eval
"guide-utils.ss") "guide-utils.ss")
@title{@bold{Guide}: PLT Scheme} @title{@bold{Guide}: PLT Scheme}

8
collects/scribblings/guide/paths.scrbl
View File

@ -38,11 +38,11 @@ values, instead of strings.
Although it's sometimes tempting to directly manipulate strings that Although it's sometimes tempting to directly manipulate strings that
represent filesystem paths, correctly manipulating a path can be represent filesystem paths, correctly manipulating a path can be
surprisingly difficult. For example, if you start under Unix with the surprisingly difficult. For example, if you start under Unix with the
absolute path @file{/tmp/~} and take just the last part, you end up absolute path @filepath{/tmp/~} and take just the last part, you end up
with @file{~}---which looks like a reference to the current user's with @filepath{~}---which looks like a reference to the current user's
home directory, instead of a relative path to a file of directory home directory, instead of a relative path to a file of directory
named @file{~}. Windows path manipulation, furthermore, is far named @filepath{~}. Windows path manipulation, furthermore, is far
trickier, because path elements like @file{aux} can have special trickier, because path elements like @filepath{aux} can have special
meanings. meanings.
@refdetails/gory["windows-path"]{Windows filesystem paths} @refdetails/gory["windows-path"]{Windows filesystem paths}

3
collects/scribblings/guide/regexp.scrbl
View File

@ -1,6 +1,7 @@
#lang scribble/doc #lang scribble/doc
@(require scribble/manual @(require scribble/manual
scribble/eval scribble/eval
scribble/core
"guide-utils.ss") "guide-utils.ss")
@title[#:tag "regexp" #:style 'toc]{Regular Expressions} @title[#:tag "regexp" #:style 'toc]{Regular Expressions}
@ -358,7 +359,7 @@ the form @litchar{[:}...@litchar{:]} that can be used only inside a
bracketed expression in @litchar{#px} syntax. The POSIX classes bracketed expression in @litchar{#px} syntax. The POSIX classes
supported are supported are
@itemize[#:style "compact" @itemize[#:style (make-style "compact" null)
@item{@litchar{[:alnum:]} --- ASCII letters and digits} @item{@litchar{[:alnum:]} --- ASCII letters and digits}

22
collects/scribblings/guide/unit.scrbl
View File

@ -51,10 +51,10 @@ describes the exports of a component that implements a toy factory:
scheme] scheme]
(define-signature toy-factory^ (define-signature toy-factory^
(build-toys (code:comment (integer? -> (listof toy?))) (build-toys (code:comment #, @tt{(integer? -> (listof toy?))})
repaint (code:comment (toy? symbol? -> toy?)) repaint (code:comment #, @tt{(toy? symbol? -> toy?)})
toy? (code:comment (any/c -> boolean?)) toy? (code:comment #, @tt{(any/c -> boolean?)})
toy-color)) (code:comment (toy? -> symbol?)) toy-color)) (code:comment #, @tt{(toy? -> symbol?)})
(provide toy-factory^) (provide toy-factory^)
] ]
@ -101,9 +101,9 @@ is willing to sell only toys in a particular color.)
scheme] scheme]
(define-signature toy-store^ (define-signature toy-store^
(store-color (code:comment (-> symbol?)) (store-color (code:comment #, @tt{(-> symbol?)})
stock! (code:comment (integer? -> void?)) stock! (code:comment #, @tt{(integer? -> void?)})
get-inventory)) (code:comment (-> (listof toy?))) get-inventory)) (code:comment #, @tt{(-> (listof toy?))})
(provide toy-store^) (provide toy-store^)
] ]
@ -420,10 +420,10 @@ For example, @filepath{toy-factory-sig.ss} can be written as
@schememod[ @schememod[
scheme/signature scheme/signature
build-toys (code:comment (integer? -> (listof toy?))) build-toys (code:comment #, @tt{(integer? -> (listof toy?))})
repaint (code:comment (toy? symbol? -> toy?)) repaint (code:comment #, @tt{(toy? symbol? -> toy?)})
toy? (code:comment (any/c -> boolean?)) toy? (code:comment #, @tt{(any/c -> boolean?)})
toy-color (code:comment (toy? -> symbol?)) toy-color (code:comment #, @tt{(toy? -> symbol?)})
] ]
The signature @scheme[toy-factory^] is automatically provided from the The signature @scheme[toy-factory^] is automatically provided from the

3
collects/scribblings/inside/utils.ss
View File

@ -3,6 +3,7 @@
(require scribble/manual (require scribble/manual
scribble/struct scribble/struct
scribble/decode scribble/decode
scribble/scheme
(for-syntax scheme/base) (for-syntax scheme/base)
(for-label scheme/base)) (for-label scheme/base))
@ -140,7 +141,7 @@
(let ([d (resolve-get/tentative part ri `(cpp ,x))]) (let ([d (resolve-get/tentative part ri `(cpp ,x))])
(list (list
(if d (if d
(make-link-element "schemesyntaxlink" (list e) `(cpp ,x)) (make-link-element syntax-link-color (list e) `(cpp ,x))
e)))) e))))
(lambda () e) (lambda () e)
(lambda () e))) (lambda () e)))

19
collects/scribblings/main/private/make-search.ss
View File

@ -4,7 +4,9 @@
(require scribble/decode (require scribble/decode
scribble/decode-struct scribble/decode-struct
scribble/basic scribble/basic
scribble/struct scribble/core
scribble/scheme
scribble/html-variants
scribble/manual-struct scribble/manual-struct
scheme/list scheme/list
scheme/string scheme/string
@ -98,16 +100,16 @@
`(,@e ,(make-element "smaller" `(,@e ,(make-element "smaller"
`(" (method of " `(" (method of "
,(make-element ,(make-element
"schemesymbol" symbol-color
(list (list
(make-element (make-element
"schemevaluelink" value-link-color
(list (symbol->string (list (symbol->string
(exported-index-desc-name desc)))))) (exported-index-desc-name desc))))))
")"))) ")")))
e)] e)]
[e (make-link-element "indexlink" e tag)] [e (make-link-element "indexlink" e tag)]
[e (send renderer render-element e sec ri)]) [e (send renderer render-content e sec ri)])
(match e ; should always render to a single `a' (match e ; should always render to a single `a'
[`((a ([href ,href] [class "indexlink"]) . ,body)) [`((a ([href ,href] [class "indexlink"]) . ,body))
(cond [(and (part-index-desc? desc) (cond [(and (part-index-desc? desc)
@ -181,12 +183,15 @@
(make-splice (make-splice
(list (list
(make-paragraph (make-paragraph
plain
(list (list
(script-ref "plt-index.js" (script-ref "plt-index.js"
#:noscript #:noscript
@list{Sorry, you must have JavaScript to use this page.}) @list{Sorry, you must have JavaScript to use this page.})
(script-ref "search.js") (script-ref "search.js")
(make-render-element null null (make-render-element #f null
(lambda (r s i) (make-script user-dir? r s i))))) (lambda (r s i) (make-script user-dir? r s i)))))
(make-styled-paragraph '() (make-paragraph (make-style #f
(make-with-attributes 'div '([id . "plt_search_container"])))))) (list 'div
(make-attributes '([id . "plt_search_container"]))))
'()))))

2
collects/scribblings/main/private/search.js
View File

@ -565,7 +565,7 @@ function UpdateResults() {
note += note +=
(j==0 ? "" : ", ") (j==0 ? "" : ", ")
+ '<a href="?q=' + encodeURIComponent("L:"+desc[j]) + '"' + '<a href="?q=' + encodeURIComponent("L:"+desc[j]) + '"'
+' class="schememod" tabIndex="2"' +' class="ScmMod" tabIndex="2"'
+' title="show bindings from the '+desc[j]+' module' +' title="show bindings from the '+desc[j]+' module'
+' (right-click to refine current query)"' +' (right-click to refine current query)"'
+' style="text-decoration: none; color: #006;"' +' style="text-decoration: none; color: #006;"'

37
collects/scribblings/main/private/utils.ss
View File

@ -3,7 +3,8 @@
(require "../config.ss" (require "../config.ss"
scribble/manual scribble/manual
scribble/struct scribble/core
scribble/html-variants
scribble/decode scribble/decode
scheme/list scheme/list
setup/dirs) setup/dirs)
@ -17,10 +18,18 @@
[else (error 'main-page "page id not found: ~e" id)])))) [else (error 'main-page "page id not found: ~e" id)]))))
(define (script #:noscript [noscript null] . body) (define (script #:noscript [noscript null] . body)
(make-script-element #f noscript "text/javascript" (flatten body))) (make-element (make-style #f (list
(make-script-variant
"text/javascript"
(flatten body))))
noscript))
(define (script-ref #:noscript [noscript null] path) (define (script-ref #:noscript [noscript null] path)
(make-script-element #f noscript "text/javascript" path)) (make-element (make-style #f (list
(make-script-variant
"text/javascript"
path)))
noscript))
;; this is for content that should not be displayed on the web (this ;; this is for content that should not be displayed on the web (this
;; is done by a class name that is not included in the usual css file, ;; is done by a class name that is not included in the usual css file,
@ -42,7 +51,15 @@
;; massage the current path to an up string ;; massage the current path to an up string
(regexp-replace* #rx"[^/]*/" (regexp-replace #rx"[^/]+$" path "") "../")) (regexp-replace* #rx"[^/]*/" (regexp-replace #rx"[^/]+$" path "") "../"))
(define page-title (define page-title
(title #:style '(no-toc) title-string (title #:style (make-style #f (cons
'no-toc
(if user-doc?
null
;; Ensure that "scheme.css" gets installed in the shared location:
(list
(make-css-addition (build-path (collection-path "scribble")
"scheme.css"))))))
title-string
#; #;
;; the "(installation)" part shouldn't be visible on the web, but ;; the "(installation)" part shouldn't be visible on the web, but
;; there's no way (currently) to not have it in the window title ;; there's no way (currently) to not have it in the window title
@ -88,14 +105,14 @@
[else (error "internal error (main-page)")])) [else (error "internal error (main-page)")]))
(define (onclick style) (define (onclick style)
(if (eq? root 'user) (if (eq? root 'user)
(make-with-attributes (make-style style
style (list (make-attributes
`([onclick `([onclick
. ,(format "return GotoPLTRoot(\"~a\", \"~a\");" . ,(format "return GotoPLTRoot(\"~a\", \"~a\");"
(version) path)])) (version) path)]))))
style)) style))
(define (elt style) (define (elt style)
(make-toc-element (make-toc-element
#f null (list (link dest #:style (onclick style) text)))) #f null (list (hyperlink dest #:style (onclick style) text))))
(list id (elt "tocviewlink") (elt "tocviewselflink"))))) (list id (elt "tocviewlink") (elt "tocviewselflink")))))
links)) links))

204
collects/scribblings/quick/images/exprs.dat
View File

@ -1,102 +1,102 @@
((1) 0 () 0 () () 5) ((2) 0 () 0 () () 5)
((1) 0 () 0 () () 5) ((2) 0 () 0 () () 5)
((1) 0 () 0 () () (c begin c "art gallery")) ((2) 0 () 0 () () (c begin c "art gallery"))
((1) 0 () 0 () () "art gallery") ((2) 0 () 0 () () "art gallery")
((1) 0 () 0 () () (c circle c 10)) ((2) 0 () 0 () () (c circle c 10))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img0.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img0") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c rectangle c 10 c 20)) ((2) 0 () 0 () () (c rectangle c 10 c 20))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img1.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img1") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c circle c 10 c 20)) ((2) 0 () 0 () () (c circle c 10 c 20))
((1) 1 (((lib "scriblib/private/gui-eval-exn.ss") . deserialize-info:gui-exn-v0)) 0 () () (0 "procedure circle: expects 1 argument, given 2: 10 20")) ((2) 1 (((lib "scriblib/private/gui-eval-exn.ss") . deserialize-info:gui-exn-v0)) 0 () () (0 "procedure circle: expects 1 argument, given 2: 10 20"))
((1) 0 () 0 () () (c hc-append c (c circle c 10) c (c rectangle c 10 c 20))) ((2) 0 () 0 () () (c hc-append c (c circle c 10) c (c rectangle c 10 c 20)))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img2.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img2") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c define c c c (c circle c 10))) ((2) 0 () 0 () () (c define c c c (c circle c 10)))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c define c r c (c rectangle c 10 c 20))) ((2) 0 () 0 () () (c define c r c (c rectangle c 10 c 20)))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () r) ((2) 0 () 0 () () r)
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img3.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img3") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c hc-append c c c r)) ((2) 0 () 0 () () (c hc-append c c c r))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img4.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img4") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c hc-append c 20 c c c r c c)) ((2) 0 () 0 () () (c hc-append c 20 c c c r c c))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img5.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img5") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c define c (c square c n) c (c filled-rectangle c n c n))) ((2) 0 () 0 () () (c define c (c square c n) c (c filled-rectangle c n c n)))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c square c 10)) ((2) 0 () 0 () () (c square c 10))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img6.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img6") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c define c (c four c p) c (c define c two-p c (c hc-append c p c p)) c (c vc-append c two-p c two-p))) ((2) 0 () 0 () () (c define c (c four c p) c (c define c two-p c (c hc-append c p c p)) c (c vc-append c two-p c two-p)))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c four c (c circle c 10))) ((2) 0 () 0 () () (c four c (c circle c 10)))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img7.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img7") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c define c (c checker c p1 c p2) c (c let c (c (c p12 c (c hc-append c p1 c p2)) c (c p21 c (c hc-append c p2 c p1))) c (c vc-append c p12 c p21)))) ((2) 0 () 0 () () (c define c (c checker c p1 c p2) c (c let c (c (c p12 c (c hc-append c p1 c p2)) c (c p21 c (c hc-append c p2 c p1))) c (c vc-append c p12 c p21))))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c checker c (c colorize c (c square c 10) c "red") c (c colorize c (c square c 10) c "black"))) ((2) 0 () 0 () () (c checker c (c colorize c (c square c 10) c "red") c (c colorize c (c square c 10) c "black")))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img8.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img8") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c define c (c checkerboard c p) c (c let* c (c (c rp c (c colorize c p c "red")) c (c bp c (c colorize c p c "black")) c (c c c (c checker c rp c bp)) c (c c4 c (c four c c))) c (c four c c4)))) ((2) 0 () 0 () () (c define c (c checkerboard c p) c (c let* c (c (c rp c (c colorize c p c "red")) c (c bp c (c colorize c p c "black")) c (c c c (c checker c rp c bp)) c (c c4 c (c four c c))) c (c four c c4))))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c checkerboard c (c square c 10))) ((2) 0 () 0 () () (c checkerboard c (c square c 10)))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img9.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img9") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () circle) ((2) 0 () 0 () () circle)
((1) 1 (((lib "scribble/struct.ss") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#<procedure:circle>")))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#<procedure:circle>"))))
((1) 0 () 0 () () (c define c (c series c mk) c (c hc-append c 4 c (c mk c 5) c (c mk c 10) c (c mk c 20)))) ((2) 0 () 0 () () (c define c (c series c mk) c (c hc-append c 4 c (c mk c 5) c (c mk c 10) c (c mk c 20))))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c series c circle)) ((2) 0 () 0 () () (c series c circle))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img10.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img10") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c series c square)) ((2) 0 () 0 () () (c series c square))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img11.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img11") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c series c (c lambda c (c size) c (c checkerboard c (c square c size))))) ((2) 0 () 0 () () (c series c (c lambda c (c size) c (c checkerboard c (c square c size)))))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img12.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img12") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c define c (c rgb-series c mk) c (c vc-append c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "red"))) c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "green"))) c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "blue")))))) ((2) 0 () 0 () () (c define c (c rgb-series c mk) c (c vc-append c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "red"))) c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "green"))) c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "blue"))))))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c rgb-series c circle)) ((2) 0 () 0 () () (c rgb-series c circle))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img13.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img13") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c rgb-series c square)) ((2) 0 () 0 () () (c rgb-series c square))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img14.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img14") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c define c (c rgb-maker c mk) c (c lambda c (c sz) c (c vc-append c (c colorize c (c mk c sz) c "red") c (c colorize c (c mk c sz) c "green") c (c colorize c (c mk c sz) c "blue"))))) ((2) 0 () 0 () () (c define c (c rgb-maker c mk) c (c lambda c (c sz) c (c vc-append c (c colorize c (c mk c sz) c "red") c (c colorize c (c mk c sz) c "green") c (c colorize c (c mk c sz) c "blue")))))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c series c (c rgb-maker c circle))) ((2) 0 () 0 () () (c series c (c rgb-maker c circle)))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img15.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img15") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c series c (c rgb-maker c square))) ((2) 0 () 0 () () (c series c (c rgb-maker c square)))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img16.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img16") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c list c "red" c "green" c "blue")) ((2) 0 () 0 () () (c list c "red" c "green" c "blue"))
((1) 0 () 0 () () (c "red" c "green" c "blue")) ((2) 0 () 0 () () (c "red" c "green" c "blue"))
((1) 0 () 0 () () (c list c (c circle c 10) c (c square c 10))) ((2) 0 () 0 () () (c list c (c circle c 10) c (c square c 10)))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 1 ("[image]") () (c (0 #f (c (0 (1 (u . "images/img17.pdf") 1.0) (c (? . 0))))) c (0 #f (c (0 (1 (u . "images/img18.pdf") 1.0) (c (? . 0))))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 2 ("[image]" (c ".pdf" c ".png")) () (c (0 #f (c (? . 0)) (u . "images/img17") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img18") (? . 1) 1.0)))
((1) 0 () 0 () () (c define c (c rainbow c p) c (c map c (c lambda c (c color) c (c colorize c p c color)) c (c list c "red" c "orange" c "yellow" c "green" c "blue" c "purple")))) ((2) 0 () 0 () () (c define c (c rainbow c p) c (c map c (c lambda c (c color) c (c colorize c p c color)) c (c list c "red" c "orange" c "yellow" c "green" c "blue" c "purple"))))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c rainbow c (c square c 5))) ((2) 0 () 0 () () (c rainbow c (c square c 5)))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 1 ("[image]") () (c (0 #f (c (0 (1 (u . "images/img19.pdf") 1.0) (c (? . 0))))) c (0 #f (c (0 (1 (u . "images/img20.pdf") 1.0) (c (? . 0))))) c (0 #f (c (0 (1 (u . "images/img21.pdf") 1.0) (c (? . 0))))) c (0 #f (c (0 (1 (u . "images/img22.pdf") 1.0) (c (? . 0))))) c (0 #f (c (0 (1 (u . "images/img23.pdf") 1.0) (c (? . 0))))) c (0 #f (c (0 (1 (u . "images/img24.pdf") 1.0) (c (? . 0))))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 2 ("[image]" (c ".pdf" c ".png")) () (c (0 #f (c (? . 0)) (u . "images/img19") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img20") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img21") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img22") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img23") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img24") (? . 1) 1.0)))
((1) 0 () 0 () () (c apply c vc-append c (c rainbow c (c square c 5)))) ((2) 0 () 0 () () (c apply c vc-append c (c rainbow c (c square c 5))))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img25.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img25") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c require c slideshow/flash)) ((2) 0 () 0 () () (c require c slideshow/flash))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c filled-flash c 40 c 30)) ((2) 0 () 0 () () (c filled-flash c 40 c 30))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img26.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img26") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c require c (c planet c "random.ss" c (c "schematics" c "random.plt" c 1 c 0)))) ((2) 0 () 0 () () (c require c (c planet c "random.ss" c (c "schematics" c "random.plt" c 1 c 0))))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c random-gaussian)) ((2) 0 () 0 () () (c random-gaussian))
((1) 0 () 0 () () 0.7386912134436788) ((2) 0 () 0 () () 0.7386912134436788)
((1) 0 () 0 () () (c require c slideshow/code)) ((2) 0 () 0 () () (c require c slideshow/code))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c code c (c circle c 10))) ((2) 0 () 0 () () (c code c (c circle c 10)))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img27.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img27") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c define-syntax c pict+code c (c syntax-rules c () c (c (c pict+code c expr) c (c hc-append c 10 c expr c (c code c expr)))))) ((2) 0 () 0 () () (c define-syntax c pict+code c (c syntax-rules c () c (c (c pict+code c expr) c (c hc-append c 10 c expr c (c code c expr))))))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c pict+code c (c circle c 10))) ((2) 0 () 0 () () (c pict+code c (c circle c 10)))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img28.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img28") (c ".pdf" c ".png") 1.0))
((1) 0 () 0 () () (c require c scheme/class c scheme/gui/base)) ((2) 0 () 0 () () (c require c scheme/class c scheme/gui/base))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c define c f c (c new c frame% c (c label c "My Art") c (c width c 300) c (c height c 300) c (c alignment c (c quote c (c center c center)))))) ((2) 0 () 0 () () (c define c f c (c new c frame% c (c label c "My Art") c (c width c 300) c (c height c 300) c (c alignment c (c quote c (c center c center))))))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c send c f c show c #t)) ((2) 0 () 0 () () (c send c f c show c #t))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c send c f c show c #f)) ((2) 0 () 0 () () (c send c f c show c #f))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c define c (c add-drawing c p) c (c let c (c (c drawer c (c make-pict-drawer c p))) c (c new c canvas% c (c parent c f) c (c style c (c quote c (c border))) c (c paint-callback c (c lambda c (c self c dc) c (c drawer c dc c 0 c 0))))))) ((2) 0 () 0 () () (c define c (c add-drawing c p) c (c let c (c (c drawer c (c make-pict-drawer c p))) c (c new c canvas% c (c parent c f) c (c style c (c quote c (c border))) c (c paint-callback c (c lambda c (c self c dc) c (c drawer c dc c 0 c 0)))))))
((1) 0 () 0 () () (void)) ((2) 0 () 0 () () (void))
((1) 0 () 0 () () (c add-drawing c (c pict+code c (c circle c 10)))) ((2) 0 () 0 () () (c add-drawing c (c pict+code c (c circle c 10))))
((1) 1 (((lib "scribble/struct.ss") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)")))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)"))))
((1) 0 () 0 () () (c add-drawing c (c colorize c (c filled-flash c 50 c 30) c "yellow"))) ((2) 0 () 0 () () (c add-drawing c (c colorize c (c filled-flash c 50 c 30) c "yellow")))
((1) 1 (((lib "scribble/struct.ss") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)")))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)"))))
((1) 0 () 0 () () (c scale c (c bitmap c (c build-path c (c collection-path c "scribblings/quick") c "art.png")) c 0.5)) ((2) 0 () 0 () () (c scale c (c bitmap c (c build-path c (c collection-path c "scribblings/quick") c "art.png")) c 0.5))
((1) 2 (((lib "scribble/struct.ss") . deserialize-info:element-v0) ((lib "scribble/struct.ss") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img29.pdf") 1.0) (c "[image]"))))) ((2) 1 (((lib "scribble/core.ss") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img29") (c ".pdf" c ".png") 1.0))

BIN
collects/scribblings/quick/images/img0.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img1.pdf
View File

Binary file not shown.

14
collects/scribblings/quick/images/img10.pdf
View File

@ -42,10 +42,10 @@ endobj
<?adobe-xap-filters esc="CRLF"?> <?adobe-xap-filters esc="CRLF"?>
<x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'> <x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'>
<rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'> <rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'>
<rdf:Description rdf:about='6be08af7-4062-11e9-0000-34a7f4bf94ee' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/> <rdf:Description rdf:about='f22d160f-af3b-11e9-0000-34a7f4bf94ee' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<rdf:Description rdf:about='6be08af7-4062-11e9-0000-34a7f4bf94ee' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-03-03T15:51:46-07:00' xap:CreateDate='2009-03-03T15:51:46-07:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description> <rdf:Description rdf:about='f22d160f-af3b-11e9-0000-34a7f4bf94ee' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-07-22T18:26:00-06:00' xap:CreateDate='2009-07-22T18:26:00-06:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description>
<rdf:Description rdf:about='6be08af7-4062-11e9-0000-34a7f4bf94ee' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='6be08af7-4062-11e9-0000-34a7f4bf94ee'/> <rdf:Description rdf:about='f22d160f-af3b-11e9-0000-34a7f4bf94ee' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='f22d160f-af3b-11e9-0000-34a7f4bf94ee'/>
<rdf:Description rdf:about='6be08af7-4062-11e9-0000-34a7f4bf94ee' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description> <rdf:Description rdf:about='f22d160f-af3b-11e9-0000-34a7f4bf94ee' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description>
</rdf:RDF> </rdf:RDF>
</x:xmpmeta> </x:xmpmeta>
@ -55,8 +55,8 @@ endstream
endobj endobj
2 0 obj 2 0 obj
<</Producer(GPL Ghostscript 8.63) <</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155146-07'00') /CreationDate(D:20090722182600-06'00')
/ModDate(D:20090303155146-07'00') /ModDate(D:20090722182600-06'00')
/Creator(PLT Scheme) /Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj /Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref xref
@ -73,7 +73,7 @@ xref
0000000640 00000 n 0000000640 00000 n
trailer trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R << /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<5B9C18337FC8389A1DFF2A1017EF4F38><5B9C18337FC8389A1DFF2A1017EF4F38>] /ID [<359940CD83EE8F3FC014C34CE1255CDE><359940CD83EE8F3FC014C34CE1255CDE>]
>> >>
startxref startxref
2278 2278

BIN
collects/scribblings/quick/images/img11.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img12.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img13.pdf
View File

Binary file not shown.

14
collects/scribblings/quick/images/img14.pdf
View File

@ -42,10 +42,10 @@ endobj
<?adobe-xap-filters esc="CRLF"?> <?adobe-xap-filters esc="CRLF"?>
<x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'> <x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'>
<rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'> <rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'>
<rdf:Description rdf:about='6be08af7-4062-11e9-0000-de937bc06cc7' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/> <rdf:Description rdf:about='f2c5ac8f-af3b-11e9-0000-de937bc06cc7' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<rdf:Description rdf:about='6be08af7-4062-11e9-0000-de937bc06cc7' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-03-03T15:51:46-07:00' xap:CreateDate='2009-03-03T15:51:46-07:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description> <rdf:Description rdf:about='f2c5ac8f-af3b-11e9-0000-de937bc06cc7' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-07-22T18:26:01-06:00' xap:CreateDate='2009-07-22T18:26:01-06:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description>
<rdf:Description rdf:about='6be08af7-4062-11e9-0000-de937bc06cc7' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='6be08af7-4062-11e9-0000-de937bc06cc7'/> <rdf:Description rdf:about='f2c5ac8f-af3b-11e9-0000-de937bc06cc7' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='f2c5ac8f-af3b-11e9-0000-de937bc06cc7'/>
<rdf:Description rdf:about='6be08af7-4062-11e9-0000-de937bc06cc7' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description> <rdf:Description rdf:about='f2c5ac8f-af3b-11e9-0000-de937bc06cc7' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description>
</rdf:RDF> </rdf:RDF>
</x:xmpmeta> </x:xmpmeta>
@ -55,8 +55,8 @@ endstream
endobj endobj
2 0 obj 2 0 obj
<</Producer(GPL Ghostscript 8.63) <</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155146-07'00') /CreationDate(D:20090722182601-06'00')
/ModDate(D:20090303155146-07'00') /ModDate(D:20090722182601-06'00')
/Creator(PLT Scheme) /Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj /Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref xref
@ -73,7 +73,7 @@ xref
0000000577 00000 n 0000000577 00000 n
trailer trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R << /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<D1DCD84F7619933E209882189C123385><D1DCD84F7619933E209882189C123385>] /ID [<B544940615DB98AEC7D1DC63F54A451E><B544940615DB98AEC7D1DC63F54A451E>]
>> >>
startxref startxref
2215 2215

BIN
collects/scribblings/quick/images/img15.pdf
View File

Binary file not shown.

14
collects/scribblings/quick/images/img16.pdf
View File

@ -42,10 +42,10 @@ endobj
<?adobe-xap-filters esc="CRLF"?> <?adobe-xap-filters esc="CRLF"?>
<x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'> <x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'>
<rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'> <rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'>
<rdf:Description rdf:about='6c792177-4062-11e9-0000-11040068121c' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/> <rdf:Description rdf:about='f35e430f-af3b-11e9-0000-11040068121c' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<rdf:Description rdf:about='6c792177-4062-11e9-0000-11040068121c' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-03-03T15:51:47-07:00' xap:CreateDate='2009-03-03T15:51:47-07:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description> <rdf:Description rdf:about='f35e430f-af3b-11e9-0000-11040068121c' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-07-22T18:26:02-06:00' xap:CreateDate='2009-07-22T18:26:02-06:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description>
<rdf:Description rdf:about='6c792177-4062-11e9-0000-11040068121c' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='6c792177-4062-11e9-0000-11040068121c'/> <rdf:Description rdf:about='f35e430f-af3b-11e9-0000-11040068121c' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='f35e430f-af3b-11e9-0000-11040068121c'/>
<rdf:Description rdf:about='6c792177-4062-11e9-0000-11040068121c' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description> <rdf:Description rdf:about='f35e430f-af3b-11e9-0000-11040068121c' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description>
</rdf:RDF> </rdf:RDF>
</x:xmpmeta> </x:xmpmeta>
@ -55,8 +55,8 @@ endstream
endobj endobj
2 0 obj 2 0 obj
<</Producer(GPL Ghostscript 8.63) <</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155147-07'00') /CreationDate(D:20090722182602-06'00')
/ModDate(D:20090303155147-07'00') /ModDate(D:20090722182602-06'00')
/Creator(PLT Scheme) /Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj /Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref xref
@ -73,7 +73,7 @@ xref
0000000588 00000 n 0000000588 00000 n
trailer trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R << /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<1AE0C6090561E21FACDD570510EAE550><1AE0C6090561E21FACDD570510EAE550>] /ID [<3F728FBF71FC3EE42151B158C78C6E47><3F728FBF71FC3EE42151B158C78C6E47>]
>> >>
startxref startxref
2226 2226

BIN
collects/scribblings/quick/images/img17.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img18.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img19.pdf
View File

Binary file not shown.

14
collects/scribblings/quick/images/img2.pdf
View File

@ -44,10 +44,10 @@ endobj
<?adobe-xap-filters esc="CRLF"?> <?adobe-xap-filters esc="CRLF"?>
<x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'> <x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'>
<rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'> <rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'>
<rdf:Description rdf:about='6aaf5df7-4062-11e9-0000-2bb4b895d559' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/> <rdf:Description rdf:about='f0fbe90f-af3b-11e9-0000-2bb4b895d559' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<rdf:Description rdf:about='6aaf5df7-4062-11e9-0000-2bb4b895d559' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-03-03T15:51:44-07:00' xap:CreateDate='2009-03-03T15:51:44-07:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description> <rdf:Description rdf:about='f0fbe90f-af3b-11e9-0000-2bb4b895d559' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-07-22T18:25:58-06:00' xap:CreateDate='2009-07-22T18:25:58-06:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description>
<rdf:Description rdf:about='6aaf5df7-4062-11e9-0000-2bb4b895d559' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='6aaf5df7-4062-11e9-0000-2bb4b895d559'/> <rdf:Description rdf:about='f0fbe90f-af3b-11e9-0000-2bb4b895d559' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='f0fbe90f-af3b-11e9-0000-2bb4b895d559'/>
<rdf:Description rdf:about='6aaf5df7-4062-11e9-0000-2bb4b895d559' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description> <rdf:Description rdf:about='f0fbe90f-af3b-11e9-0000-2bb4b895d559' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description>
</rdf:RDF> </rdf:RDF>
</x:xmpmeta> </x:xmpmeta>
@ -57,8 +57,8 @@ endstream
endobj endobj
2 0 obj 2 0 obj
<</Producer(GPL Ghostscript 8.63) <</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155144-07'00') /CreationDate(D:20090722182558-06'00')
/ModDate(D:20090303155144-07'00') /ModDate(D:20090722182558-06'00')
/Creator(PLT Scheme) /Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj /Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref xref
@ -75,7 +75,7 @@ xref
0000000546 00000 n 0000000546 00000 n
trailer trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R << /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<390C745AD3529AFF7AA2F07ADD0F632F><390C745AD3529AFF7AA2F07ADD0F632F>] /ID [<BF3BAD7CB407F5E17AE00BD540FA6C1B><BF3BAD7CB407F5E17AE00BD540FA6C1B>]
>> >>
startxref startxref
2184 2184

BIN
collects/scribblings/quick/images/img20.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img21.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img22.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img23.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img24.pdf
View File

Binary file not shown.

14
collects/scribblings/quick/images/img25.pdf
View File

@ -43,10 +43,10 @@ endobj
<?adobe-xap-filters esc="CRLF"?> <?adobe-xap-filters esc="CRLF"?>
<x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'> <x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'>
<rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'> <rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'>
<rdf:Description rdf:about='6daa4e77-4062-11e9-0000-fcfa74cec07e' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/> <rdf:Description rdf:about='f48f700f-af3b-11e9-0000-fcfa74cec07e' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<rdf:Description rdf:about='6daa4e77-4062-11e9-0000-fcfa74cec07e' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-03-03T15:51:49-07:00' xap:CreateDate='2009-03-03T15:51:49-07:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description> <rdf:Description rdf:about='f48f700f-af3b-11e9-0000-fcfa74cec07e' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-07-22T18:26:04-06:00' xap:CreateDate='2009-07-22T18:26:04-06:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description>
<rdf:Description rdf:about='6daa4e77-4062-11e9-0000-fcfa74cec07e' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='6daa4e77-4062-11e9-0000-fcfa74cec07e'/> <rdf:Description rdf:about='f48f700f-af3b-11e9-0000-fcfa74cec07e' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='f48f700f-af3b-11e9-0000-fcfa74cec07e'/>
<rdf:Description rdf:about='6daa4e77-4062-11e9-0000-fcfa74cec07e' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description> <rdf:Description rdf:about='f48f700f-af3b-11e9-0000-fcfa74cec07e' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description>
</rdf:RDF> </rdf:RDF>
</x:xmpmeta> </x:xmpmeta>
@ -56,8 +56,8 @@ endstream
endobj endobj
2 0 obj 2 0 obj
<</Producer(GPL Ghostscript 8.63) <</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155149-07'00') /CreationDate(D:20090722182604-06'00')
/ModDate(D:20090303155149-07'00') /ModDate(D:20090722182604-06'00')
/Creator(PLT Scheme) /Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj /Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref xref
@ -74,7 +74,7 @@ xref
0000000577 00000 n 0000000577 00000 n
trailer trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R << /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<D47DD8E8F4F6B70E9917B60988320218><D47DD8E8F4F6B70E9917B60988320218>] /ID [<F1ECA86EA72818308D60B49648AD980D><F1ECA86EA72818308D60B49648AD980D>]
>> >>
startxref startxref
2215 2215

14
collects/scribblings/quick/images/img26.pdf
View File

@ -42,10 +42,10 @@ endobj
<?adobe-xap-filters esc="CRLF"?> <?adobe-xap-filters esc="CRLF"?>
<x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'> <x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'>
<rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'> <rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'>
<rdf:Description rdf:about='6daa4e77-4062-11e9-0000-2bb5249de6dd' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/> <rdf:Description rdf:about='f48f700f-af3b-11e9-0000-2bb5249de6dd' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<rdf:Description rdf:about='6daa4e77-4062-11e9-0000-2bb5249de6dd' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-03-03T15:51:49-07:00' xap:CreateDate='2009-03-03T15:51:49-07:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description> <rdf:Description rdf:about='f48f700f-af3b-11e9-0000-2bb5249de6dd' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-07-22T18:26:04-06:00' xap:CreateDate='2009-07-22T18:26:04-06:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description>
<rdf:Description rdf:about='6daa4e77-4062-11e9-0000-2bb5249de6dd' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='6daa4e77-4062-11e9-0000-2bb5249de6dd'/> <rdf:Description rdf:about='f48f700f-af3b-11e9-0000-2bb5249de6dd' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='f48f700f-af3b-11e9-0000-2bb5249de6dd'/>
<rdf:Description rdf:about='6daa4e77-4062-11e9-0000-2bb5249de6dd' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description> <rdf:Description rdf:about='f48f700f-af3b-11e9-0000-2bb5249de6dd' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description>
</rdf:RDF> </rdf:RDF>
</x:xmpmeta> </x:xmpmeta>
@ -55,8 +55,8 @@ endstream
endobj endobj
2 0 obj 2 0 obj
<</Producer(GPL Ghostscript 8.63) <</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155149-07'00') /CreationDate(D:20090722182604-06'00')
/ModDate(D:20090303155149-07'00') /ModDate(D:20090722182604-06'00')
/Creator(PLT Scheme) /Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj /Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref xref
@ -73,7 +73,7 @@ xref
0000000622 00000 n 0000000622 00000 n
trailer trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R << /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<BE08CA6AB9E961B083F33BBF7F8A8E2B><BE08CA6AB9E961B083F33BBF7F8A8E2B>] /ID [<5B1279F9960652F0F9499AE6C2394568><5B1279F9960652F0F9499AE6C2394568>]
>> >>
startxref startxref
2260 2260

BIN
collects/scribblings/quick/images/img27.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img28.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img29.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img3.pdf
View File

Binary file not shown.

14
collects/scribblings/quick/images/img4.pdf
View File

@ -44,10 +44,10 @@ endobj
<?adobe-xap-filters esc="CRLF"?> <?adobe-xap-filters esc="CRLF"?>
<x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'> <x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='XMP toolkit 2.9.1-13, framework 1.6'>
<rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'> <rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns:iX='http://ns.adobe.com/iX/1.0/'>
<rdf:Description rdf:about='6aaf5df7-4062-11e9-0000-2bb4b895d559' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/> <rdf:Description rdf:about='f1947f8f-af3b-11e9-0000-2bb4b895d559' xmlns:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<rdf:Description rdf:about='6aaf5df7-4062-11e9-0000-2bb4b895d559' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-03-03T15:51:44-07:00' xap:CreateDate='2009-03-03T15:51:44-07:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description> <rdf:Description rdf:about='f1947f8f-af3b-11e9-0000-2bb4b895d559' xmlns:xap='http://ns.adobe.com/xap/1.0/' xap:ModifyDate='2009-07-22T18:25:59-06:00' xap:CreateDate='2009-07-22T18:25:59-06:00'><xap:CreatorTool>PLT Scheme</xap:CreatorTool></rdf:Description>
<rdf:Description rdf:about='6aaf5df7-4062-11e9-0000-2bb4b895d559' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='6aaf5df7-4062-11e9-0000-2bb4b895d559'/> <rdf:Description rdf:about='f1947f8f-af3b-11e9-0000-2bb4b895d559' xmlns:xapMM='http://ns.adobe.com/xap/1.0/mm/' xapMM:DocumentID='f1947f8f-af3b-11e9-0000-2bb4b895d559'/>
<rdf:Description rdf:about='6aaf5df7-4062-11e9-0000-2bb4b895d559' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description> <rdf:Description rdf:about='f1947f8f-af3b-11e9-0000-2bb4b895d559' xmlns:dc='http://purl.org/dc/elements/1.1/' dc:format='application/pdf'><dc:title><rdf:Alt><rdf:li xml:lang='x-default'>Untitled</rdf:li></rdf:Alt></dc:title><dc:creator><rdf:Seq><rdf:li>mflatt@Macintosh \(Matthew Flatt\)</rdf:li></rdf:Seq></dc:creator></rdf:Description>
</rdf:RDF> </rdf:RDF>
</x:xmpmeta> </x:xmpmeta>
@ -57,8 +57,8 @@ endstream
endobj endobj
2 0 obj 2 0 obj
<</Producer(GPL Ghostscript 8.63) <</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155144-07'00') /CreationDate(D:20090722182559-06'00')
/ModDate(D:20090303155144-07'00') /ModDate(D:20090722182559-06'00')
/Creator(PLT Scheme) /Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj /Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref xref
@ -75,7 +75,7 @@ xref
0000000546 00000 n 0000000546 00000 n
trailer trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R << /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<A95CA727A37F788F07D908E7B89358F0><A95CA727A37F788F07D908E7B89358F0>] /ID [<6E7272D6B2731DC8CB2BE347FB5EA742><6E7272D6B2731DC8CB2BE347FB5EA742>]
>> >>
startxref startxref
2184 2184

BIN
collects/scribblings/quick/images/img5.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img6.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img7.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img8.pdf
View File

Binary file not shown.

BIN
collects/scribblings/quick/images/img9.pdf
View File

Binary file not shown.

2
collects/scribblings/quick/keep.ss
View File

@ -7,6 +7,6 @@
(define (keep-file file) (define (keep-file file)
(make-render-element (make-render-element
(make-element #f (list)) #f
null null
(lambda (r s i) (send r install-file file)))) (lambda (r s i) (send r install-file file))))

3
collects/scribblings/reference/cont-marks.scrbl
View File

@ -1,9 +1,10 @@
#lang scribble/doc #lang scribble/doc
@(require scribble/struct @(require scribble/struct
scribble/scheme
"mz.ss") "mz.ss")
@(define (cont n) @(define (cont n)
(make-element "schemevariable" (make-element variable-color
(list "C" (make-element 'subscript (list (format "~a" n)))))) (list "C" (make-element 'subscript (list (format "~a" n))))))
@title[#:tag "contmarks"]{Continuation Marks} @title[#:tag "contmarks"]{Continuation Marks}

5
collects/scribblings/reference/eval-model.scrbl
View File

@ -1,5 +1,6 @@
#lang scribble/doc #lang scribble/doc
@(require scribble/struct @(require scribble/struct
scribble/scheme
(for-syntax scheme/base) (for-syntax scheme/base)
"mz.ss" "mz.ss"
"prog-steps.ss") "prog-steps.ss")
@ -8,7 +9,7 @@
@(define rspace (make-element "ghost" (list 'rarr))) @(define rspace (make-element "ghost" (list 'rarr)))
@(define *redex (lambda (c) @(define *redex (lambda (c)
(make-element "highlighted" (list c)))) (make-element highlighted-color (list c))))
@(define-syntax redex @(define-syntax redex
(syntax-rules () [(_ a) (*redex (scheme a))])) (syntax-rules () [(_ a) (*redex (scheme a))]))
@ -18,7 +19,7 @@
@(define-syntax sub @(define-syntax sub
(syntax-rules () [(_ a b) (*sub (scheme a) (scheme b))])) (syntax-rules () [(_ a b) (*sub (scheme a) (scheme b))]))
@(define (frame n) @(define (frame n)
(make-element "schemevariable" (make-element variable-color
(list "C" (make-element 'subscript (list (format "~a" n)))))) (list "C" (make-element 'subscript (list (format "~a" n))))))
@;{ @;{
These are not used; if they do get back in, then it's probably better These are not used; if they do get back in, then it's probably better

12
collects/scribblings/reference/extras.css Normal file
View File

@ -0,0 +1,12 @@
.ghost {
color: white;
}
.inferencetop {
border-bottom: 1px solid black;
text-align: center;
}
.inferencebottom {
text-align: center;
}

4
collects/scribblings/reference/extras.tex Normal file
View File

@ -0,0 +1,4 @@
\newcommand{\inferencetop}[1]{#1}
\newcommand{\inferencebottom}[1]{\hline #1}

15
collects/scribblings/reference/help.scrbl
View File

@ -1,17 +1,20 @@
#lang scribble/doc #lang scribble/doc
@(require "mz.ss" @(require "mz.ss"
scribble/struct scribble/core
scribble/html-variants
(for-label scheme/help (for-label scheme/help
net/url net/url
scheme/gui)) scheme/gui))
@; Beware of this hard-wired link to the main doc page: @; Beware of this hard-wired link to the main doc page:
@(define main-doc-page @(define main-doc-page
(link "../index.html" (hyperlink "../index.html"
#:style (make-with-attributes #:style (make-style
"plainlink" "plainlink"
`((onclick . ,(format "return GotoPLTRoot(\"~a\");" (version))))) (list
"main documentation page")) (make-attributes
`((onclick . ,(format "return GotoPLTRoot(\"~a\");" (version)))))))
"main documentation page"))
@title{Interactive Help} @title{Interactive Help}

12
collects/scribblings/reference/match-parse.ss
View File

@ -8,7 +8,7 @@
(provide parse-match-grammar) (provide parse-match-grammar)
(define (match-nonterm s) (define (match-nonterm s)
(make-element "schemevariable" (list s))) (make-element variable-color (list s)))
(define (fixup s middle) (define (fixup s middle)
(lambda (m) (lambda (m)
@ -67,15 +67,15 @@
(match-nonterm (symbol->string s))] (match-nonterm (symbol->string s))]
[(QUOTE LIST LIST-REST LIST-NO-ORDER VECTOR HASH-TABLE BOX STRUCT [(QUOTE LIST LIST-REST LIST-NO-ORDER VECTOR HASH-TABLE BOX STRUCT
REGEXP PREGEXP AND OR NOT APP ? QUASIQUOTE CONS MCONS) REGEXP PREGEXP AND OR NOT APP ? QUASIQUOTE CONS MCONS)
(make-element "schemesymbol" (list (string-downcase (symbol->string s))))] (make-element symbol-color (list (string-downcase (symbol->string s))))]
[(***) [(***)
(make-element "schemesymbol" '("..."))] (make-element symbol-color '("..."))]
[(___) (make-element "schemesymbol" '("___"))] [(___) (make-element symbol-color '("___"))]
[(__K) [(__K)
(make-element #f (list (make-element "schemesymbol" '("__")) (make-element #f (list (make-element symbol-color '("__"))
(match-nonterm "k")))] (match-nonterm "k")))]
[(..K) [(..K)
(make-element #f (list (make-element "schemesymbol" '("..")) (make-element #f (list (make-element symbol-color '(".."))
(match-nonterm "k")))] (match-nonterm "k")))]
[else [else
s])] s])]

Some files were not shown because too many files have changed in this diff Show More