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
@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
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].
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.})
(proc-doc/names
@ -870,10 +870,10 @@
icon:get-left/right-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.
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.})
(proc-doc/names
@ -893,7 +893,7 @@
@{This returns a bitmap to be displayed in an @scheme[frame:info<%>]
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.})
(proc-doc/names
@ -1233,7 +1233,7 @@
keymap:setup-search
((is-a?/c keymap%) . -> . void?)
(keymap)
@{This extends a @link keymap with the bindings for searching.})
@{This extends a @scheme[keymap%] with the bindings for searching.})
(proc-doc/names
keymap:set-chained-keymaps
@ -1344,7 +1344,7 @@
scheme:get-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.})
(proc-doc/names

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

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

443
collects/scribble/basic.ss
View File

@ -1,443 +1,46 @@
#lang scheme/base
(require "decode.ss"
"struct.ss"
"config.ss"
"manual-struct.ss"
"decode-struct.ss"
scheme/list
scheme/class
setup/main-collects
syntax/modresolve
(for-syntax scheme/base))
(require "base.ss"
"core.ss"
"decode.ss")
(provide title
section
subsection
subsubsection
subsubsub*section
include-section)
include-section
(define (gen-tag content)
(regexp-replace* "[^-a-zA-Z0-9_=]" (content->string content) "_"))
author
author+email
(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 (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
intern-taglet
module-path-index->taglet
module-path-prefix->string)
module-path-prefix->string
itemize item item?
(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))))
;; ----------------------------------------
(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
hspace
elem aux-elem
italic bold smaller
tt span-class
subscript superscript)
tt
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)
(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)))))
table-of-contents
local-table-of-contents
(define (elem #:style [style #f] . str)
(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)))))
span-class)
(define (span-class classname . str)
(make-element classname (decode-content str)))
(define (subscript . str)
(make-element 'subscript (decode-content str)))
(define (aux-elem . s)
(make-element (make-style #f (list 'aux)) (decode-content s)))
(define (superscript . str)
(make-element 'superscript (decode-content str)))
(define (itemize #:style [style #f] . items)
(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
(require "struct.ss")
(require "core.ss"
"private/provide-structs.ss")
(provide-structs
[part-index-desc ()])

103
collects/scribble/decode.ss
View File

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

18
collects/scribble/doclang.ss
View File

@ -12,17 +12,17 @@
(define-syntax (*module-begin stx)
(syntax-case stx ()
[(_ id exprs . body)
[(_ id post-process exprs . body)
#'(#%module-begin
(doc-begin id exprs . body))]))
(doc-begin id post-process exprs . body))]))
(define-syntax (doc-begin stx)
(syntax-case stx ()
[(_ m-id (expr ...))
[(_ m-id post-process (expr ...))
#`(begin
(define m-id (decode (list . #,(reverse (syntax->list #'(expr ...))))))
(define m-id (post-process (decode (list . #,(reverse (syntax->list #'(expr ...)))))))
(provide m-id))]
[(_ m-id exprs . body)
[(_ m-id post-process exprs . body)
;; `body' probably starts with lots of string constants; it's
;; slow to trampoline on every string, so do them in a batch
;; here:
@ -34,7 +34,7 @@
(loop #'rest (cons #'s accum))]
[()
(with-syntax ([(accum ...) accum])
#`(doc-begin m-id (accum ... . exprs)))]
#`(doc-begin m-id post-process (accum ... . exprs)))]
[(body1 . body)
(with-syntax ([exprs (append accum #'exprs)])
(let ([expanded (local-expand
@ -46,7 +46,7 @@
#%require))))])
(syntax-case expanded (begin)
[(begin body1 ...)
#`(doc-begin m-id exprs body1 ... . body)]
#`(doc-begin m-id post-process exprs body1 ... . body)]
[(id . rest)
(and (identifier? #'id)
(ormap (lambda (kw) (free-identifier=? #'id kw))
@ -57,6 +57,6 @@
define-values-for-syntax
#%require
#%provide))))
#`(begin #,expanded (doc-begin m-id exprs . body))]
#`(begin #,expanded (doc-begin m-id post-process exprs . body))]
[_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)
p
(make-flow (list p))))))
(format-output (cadar val-list+outputs) "schemestdout")
(format-output (caddar val-list+outputs) "schemeerror")
(format-output (cadar val-list+outputs) output-color)
(format-output (caddar val-list+outputs) error-color)
(if (string? (caar val-list+outputs))
;; Error result case:
(map
(lambda (s)
(car (format-output s "schemeerror")))
(car (format-output s error-color)))
(let sloop ([s (caar val-list+outputs)])
(if ((string-length s) . > . maxlen)
;; break the error message into multiple lines:
@ -117,8 +117,8 @@
(list (make-flow (list (make-paragraph
(list
(hspace 2)
(span-class "schemeresult"
(to-element/no-color v))))))))
(elem #:style result-color
(to-element/no-color v))))))))
val-list))))
(loop (cdr expr-paras)
(cdr val-list+outputs)
@ -313,8 +313,8 @@
(define (show-val v)
(span-class "schemeresult"
(to-element/no-color v)))
(elem #:style result-color
(to-element/no-color v)))
(define (do-interaction-eval-show ev e)
(parameterize ([current-command-line-arguments #()])

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

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

@ -1,4 +1,17 @@
#lang scheme
(require scribble/doclang scribble/manual)
(provide (all-from-out scribble/doclang
scribble/manual))
#lang scheme/base
(require scribble/doclang
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-syntax scribble:read-syntax-inside
#:whole-body-readers? #t
#:wrapper1 (lambda (t) (list* 'doc '() (t)))
#:wrapper1 (lambda (t) (cons 'doc (t)))
(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"
"../scheme.ss"
"../search.ss"
"../config.ss"
"../basic.ss"
"../manual-struct.ss"
"manual-ex.ss"
@ -52,10 +51,10 @@
[sd (and stag (resolve-get/tentative sec ri stag))])
(list
(make-element
"schemesymbol"
symbol-color
(list
(cond [sd (make-link-element "schemesyntaxlink" (list s) stag)]
[vtag (make-link-element "schemevaluelink" (list s) vtag)]
(cond [sd (make-link-element syntax-link-color (list s) stag)]
[vtag (make-link-element value-link-color (list s) vtag)]
[else s]))))))
(lambda () s)
(lambda () s))))
@ -232,12 +231,12 @@
(list (symbol->string id))
(list
(make-element
"schemesymbol"
symbol-color
(list
(make-element
(if form?
"schemesyntaxlink"
"schemevaluelink")
syntax-link-color
value-link-color)
(list (symbol->string id))))))
((if form?
make-form-index-desc

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

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

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

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

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

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

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

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

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

@ -57,9 +57,9 @@
(syntax/loc stx (schememod #:file #f lang rest ...))]))
(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)
(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)
(syntax-case stx ()
@ -106,7 +106,7 @@
(define (as-modname-link s e)
(if (symbol? s)
(make-link-element "schememodlink"
(make-link-element module-link-color
(list e)
`(mod-path ,(symbol->string s)))
e))

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

@ -1,30 +1,34 @@
#lang scheme/base
(require "../decode.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"
scheme/list
scheme/string)
(provide PLaneT etc
litchar verbatim
image image/plain onscreen menuitem defterm emph
litchar
image (rename-out [image image/plain]) onscreen menuitem defterm
schemefont schemevalfont schemeresultfont schemeidfont schemevarfont
schemeparenfont schemekeywordfont schememetafont schememodfont
schemeerror
schemeerror schemeoutput
filepath exec envvar Flag DFlag PFlag DPFlag
indexed-file indexed-envvar
link procedure
(rename-out [hyperlink link])
(rename-out [other-doc other-manual])
(rename-out [centered centerline])
itemize
procedure
idefterm
t inset-flow
pidefterm
hash-lang
centerline
commandline
elemtag elemref
secref seclink other-manual
margin-note
commandline
void-const undefined-const
aux-elem
math)
(define PLaneT (make-element "planetName" '("PLaneT")))
@ -37,51 +41,20 @@
(let ([s (string-append* (map (lambda (s) (regexp-replace* "\n" s " "))
strs))])
(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))]
[$spaces (car (regexp-match-positions #rx" *$" s))])
(make-element
"schemeinputbg"
input-background-color
(list (hspace (cdr ^spaces))
(make-element "schemeinput"
(make-element input-color
(list (substring s (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)
(make-element 'sf (decode-content str)))
(define (menuitem menu item)
(make-element 'sf (list menu "|" item)))
(define (emph . str)
(make-element 'italic (decode-content str)))
(define (defterm . str)
(make-element 'italic (decode-content str)))
(define (idefterm . str)
@ -90,21 +63,21 @@
(define (schemefont . str)
(apply tt str))
(define (schemevalfont . str)
(make-element "schemevalue" (decode-content str)))
(make-element value-color (decode-content str)))
(define (schemeresultfont . str)
(make-element "schemeresult" (decode-content str)))
(make-element result-color (decode-content str)))
(define (schemeidfont . str)
(make-element "schemesymbol" (decode-content str)))
(make-element symbol-color (decode-content str)))
(define (schemevarfont . str)
(make-element "schemevariable" (decode-content str)))
(make-element variable-color (decode-content str)))
(define (schemeparenfont . str)
(make-element "schemeparen" (decode-content str)))
(make-element paren-color (decode-content str)))
(define (schememetafont . str)
(make-element "schememeta" (decode-content str)))
(make-element meta-color (decode-content str)))
(define (schememodfont . str)
(make-element "schememod" (decode-content str)))
(make-element module-color (decode-content str)))
(define (schemekeywordfont . str)
(make-element "schemekeyword" (decode-content str)))
(make-element keyword-color (decode-content str)))
(define (filepath . str)
(make-element 'tt (append (list "\"") (decode-content str) (list "\""))))
(define (indexed-file . str)
@ -141,17 +114,12 @@
[s (element->string f)])
(index* (list s) (list f) f)))
(define (procedure . str)
(make-element "schemeresult" `("#<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)))
(make-element result-color `("#<procedure:" ,@(decode-content str) ">")))
(define (schemeoutput . str)
(make-element output-color (decode-content str)))
(define (schemeerror . str)
(make-element "schemeerror" (decode-content str)))
(make-element error-color (decode-content str)))
(define (t . str)
(decode-paragraph str))
@ -159,11 +127,6 @@
(define (inset-flow . c)
(make-blockquote "insetpara" (flow-paragraphs (decode-flow c))))
(define (centerline . s)
(make-blockquote "SCentered" (flow-paragraphs (decode-flow s))))
(define (commandline . s)
(make-paragraph (cons (hspace 2) (map (lambda (s)
(if (string? s)
@ -171,20 +134,6 @@
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)
(let ([c (apply defterm s)])
(index (string-append (content->string (element-content c)) "s")
@ -192,26 +141,21 @@
(define (hash-lang)
(make-link-element
"schememodlink"
module-link-color
(list (schememodfont "#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
(schemeresultfont "#<void>"))
(define undefined-const
(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)
(let ([c (decode-content s)])
(make-element
@ -243,4 +187,4 @@
(list (make-element 'italic (list i)))])]
[(eq? i 'rsquo) (list 'prime)]
[else (list i)])))
c))))
c))))

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

@ -1,7 +1,7 @@
#lang scheme/base
(require "../struct.ss"
"../decode.ss"
"../basic.ss"
"../base.ss"
scheme/list)
(provide spacer doc-prefix
@ -12,17 +12,6 @@
(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)
(make-flow (list (make-omitable-paragraph (list e)))))
(define flow-spacer (to-flow spacer))

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

@ -2,6 +2,7 @@
(require "../decode.ss"
"../scheme.ss"
"../struct.ss"
(only-in "../core.ss" style-name)
(for-syntax scheme/base
syntax/kerncase
syntax/boundmap)
@ -108,7 +109,7 @@
(unless (and (box-splice? box)
(= 1 (length (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
"element is not a boxing splice containing a single table: ~e"
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
(require "struct.ss"
(require "core.ss"
"base-render.ss"
"xref.ss"
scheme/cmdline
@ -64,7 +64,7 @@
#:multi
[("++extra") file "add given file"
(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)))]
[("++info-in") file "load format-specific link information from <file>"
(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
(require "struct.ss"
(require "core.ss"
"basic.ss"
"search.ss"
"html-variants.ss"
"latex-variants.ss"
mzlib/class
mzlib/for
setup/main-collects
@ -20,6 +22,28 @@
current-variable-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 shaped-parens)
(struct-out just-context)
@ -29,16 +53,38 @@
make-element-id-transformer
element-id-transformer?))
(define no-color "schemeplain")
(define reader-color "schemereader")
(define keyword-color "schemekeyword")
(define comment-color "schemecomment")
(define paren-color "schemeparen")
(define meta-color "schememeta")
(define value-color "schemevalue")
(define symbol-color "schemesymbol")
(define variable-color "schemevariable")
(define opt-color "schemeopt")
(define scheme-variants
(let ([abs (lambda (s)
(path->main-collects-relative (build-path (collection-path "scribble") s)))])
(list (make-css-addition (abs "scheme.css"))
(make-tex-addition (abs "scheme.tex")))))
(define (make-scheme-style s #:tt? [tt? #t])
(make-style s (if tt?
(cons 'tt-chars scheme-variants)
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
(make-parameter null))
@ -66,7 +112,7 @@
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.
;; That way, when the value is no longer used, the key
@ -96,12 +142,12 @@
(list
(case (car tag)
[(form)
(make-link-element "schemesyntaxlink" (list s) tag)]
(make-link-element syntax-link-color (list s) tag)]
[else
(make-link-element "schemevaluelink" (list s) tag)]))
(make-link-element value-link-color (list s) tag)]))
(list
(make-element "badlink"
(list (make-element "schemevaluelink" (list s))))))))
(make-element value-link-color s))))))
(lambda () s)
(lambda () s)
key)])
@ -111,10 +157,8 @@
(define (make-element/cache style content)
(if (and element-cache
(pair? content)
(string? (car content))
(null? (cdr content)))
(let ([key (vector style (car content))])
(string? content))
(let ([key (vector style content)])
(let ([b (hash-ref element-cache key #f)])
(or (and b (weak-box-value b))
(let ([e (make-cached-element style content key)])
@ -184,6 +228,8 @@
[else paren-color])
(string-length s))))))
(define omitable (make-style #f '(omitable)))
(define (gen-typeset c multi-line? prefix1 prefix suffix color?)
(let* ([c (syntax-ize c 0)]
[content null]
@ -200,7 +246,7 @@
[line (or (syntax-line first) 0)])
(define (finish-line!)
(when multi-line?
(set! docs (cons (make-flow (list (make-omitable-paragraph (reverse content))))
(set! docs (cons (make-paragraph omitable (reverse content))
docs))
(set! content null)))
(define out
@ -209,16 +255,14 @@
(out v cls (let sz-loop ([v v])
(cond
[(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)]
[(and (element? v)
(= 1 (length (element-content v))))
(sz-loop (car (element-content v)))]
[(element? v)
(element-width v)]
(sz-loop (element-content v))]
[(delayed-element? v)
(element-width v)]
(content-width v)]
[(part-relative-element? v)
(element-width v)]
(content-width v)]
[(spaces? v)
(+ (sz-loop (car (element-content v)))
(spaces-cnt v)
@ -240,10 +284,10 @@
[else
(set! content (cons ((if highlight?
(lambda (c)
(make-element "highlighted" (list c)))
(make-element highlighted-color c))
values)
(if (and color? cls)
(make-element/cache cls (list v))
(make-element/cache cls v)
v))
content))
(set! dest-col (+ dest-col len))]))]))
@ -300,9 +344,9 @@
(make-sized-element
(if val? value-color #f)
(list
(make-element/cache (if val? value-color paren-color) '(". "))
(make-element/cache (if val? value-color paren-color) '". ")
(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)))
(list (syntax-source a)
(syntax-line a)
@ -564,8 +608,8 @@
(finish-line!))
(if multi-line?
(if (= 1 (length docs))
(car (flow-paragraphs (car docs)))
(make-table "schemeblock" (map list (reverse docs))))
(car docs)
(make-table block-color (map list (reverse docs))))
(make-sized-element #f (reverse content) dest-col))))
(define (typeset c multi-line? prefix1 prefix suffix color?)
@ -590,8 +634,8 @@
[(elem color len)
(if (and (string? elem)
(= len (string-length elem)))
(make-element/cache (and color? color) (list elem))
(make-sized-element (and color? color) (list elem) len))])])
(make-element/cache (and color? color) elem)
(make-sized-element (and color? color) elem len))])])
mk)
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
\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. */
/* Monospace: */
.maincolumn, .refpara, .tocset, .stt, .hspace,
.schemeinput, .schemereader, .schemeparen, .schememeta,
.schememod, .schemekeyword, .schemevariable, .schemesymbol,
.schemeresult, .schemestdout, .schemecomment, .schemevalue {
.maincolumn, .refpara, .tocset, .stt, .hspace {
font-family: monospace;
}
/* Serif: */
.main, .refcontent, .tocview, .tocsub, .inheritedlbl, i {
.main, .refcontent, .tocview, .tocsub, i {
font-family: serif;
}
/* Sans-serif: */
.version {
.version, .versionNoNav {
font-family: sans-serif;
}
@ -136,6 +133,9 @@ table td {
.version {
font-size: small;
}
.versionNoNav {
font-size: xx-small; /* avoid overlap with author */
}
/* ---------------------------------------- */
/* Margin notes */
@ -292,122 +292,9 @@ table td {
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 */
.leftindent {
margin-left: 1em;
margin-right: 0em;
}
.insetpara {
margin-left: 1em;
margin-right: 1em;
}
.indexlink {
text-decoration: none;
}
@ -437,52 +324,15 @@ ol ol ol ol { list-style-type: upper-alpha; }
i {
}
.SubFlow {
display: block;
}
.boxed {
width: 100%;
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 {
}
@ -490,14 +340,6 @@ i {
font-style: oblique;
}
.inferencetop td {
border-bottom: 1px solid black;
text-align: center;
}
.inferencebottom td {
text-align: center;
}
.badlink {
text-decoration: underline;
color: red;
@ -518,10 +360,6 @@ i {
.techinside:hover { color: blue; }
.techoutside:hover>.techinside { color: inherit; }
.SBibliography td {
vertical-align: text-top;
}
.SCentered {
text-align: center;
}
@ -531,10 +369,14 @@ i {
margin-right: 0.3em;
}
.smaller{
.Smaller{
font-size: 82%;
}
.Larger{
font-size: 122%;
}
/* A hack, inserted to break some Scheme ids: */
.mywbr {
width: 0;
@ -550,16 +392,22 @@ i {
border: 0;
}
.author {
.SAuthorListBox {
position: relative;
float: right;
left: 2em;
top: -3em;
top: -2.5em;
height: 0em;
width: 23em; /* very wide to keep author names on separate lines */
margin: 0em -23em 0em 0em;
width: 13em;
margin: 0em -13em 0em 0em;
}
.SAuthorList {
font-size: 82%;
}
.author:before {
.SAuthorList:before {
content: "by ";
}
.author {
display: inline;
white-space: nowrap;
}

125
collects/scribble/scribble.tex
View File

@ -11,47 +11,36 @@
\usepackage[usenames,dvipsnames]{color}
\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}}}}
\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}
\definecolor{PaleBlue}{rgb}{0.90,0.90,1.0}
\definecolor{LightGray}{rgb}{0.90,0.90,0.90}
% Inserted before every ``chapter'', useful for starting each one on a new page:
\newcommand{\sectionNewpage}{}
% 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{\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{\textsuper}[1]{$^{\hbox{\textsmaller{#1}}}$}
\newcommand{\intextcolor}[2]{\textcolor{#1}{#2}}
\newcommand{\intextrgbcolor}[2]{\textcolor[rgb]{#1}{#2}}
\newcommand{\incolorbox}[2]{{\fboxrule=0pt\fboxsep=0pt\colorbox{#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{\techoutside}[1]{#1}
\newcommand{\techinside}[1]{#1}
@ -59,65 +48,75 @@
\newcommand{\indexlink}[1]{#1}
\newcommand{\noborder}[1]{#1}
\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{\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}}}
\newenvironment{leftindent}{\begin{quote}}{\end{quote}}
\newenvironment{insetpara}{\begin{quote}}{\end{quote}}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Tables
\newcommand{\bibentry}[1]{\parbox[t]{0.8\linewidth}{#1}}
% stabular seems to be the lesser of all page-breaking table evironments
% The `stabular' environment seems to be the lesser of evils among
% page-breaking table environments:
\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 \\ }
% attempts to correct weirdness when a table is the first thing in
% Corrects weirdness when a table is the first thing in
% an itemization:
\newcommand{\bigtableinlinecorrect}[0]{~
\vspace{-\baselineskip}\vspace{\parskip}}
% used to indent the table correctly in an itemization, since that's
% one of the things stabular gets wrong
% Used to indent the table correctly in an itemization, since that's
% one of the things stabular gets wrong:
\newlength{\stabLeft}
\newcommand{\bigtableleftpad}{\hspace{\stabLeft}}
\newcommand{\atItemizeStart}[0]{\addtolength{\stabLeft}{\labelsep}
\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%
\listparindent=0pt\itemindent=0pt\labelwidth=0pt\leftmargin=0pt\rightmargin=0pt%
\itemsep=0pt\parsep=0pt}\item}{\end{list}}
\newenvironment{schemeblock}{}{}
\newenvironment{defmodule}{}{}
\newenvironment{prototype}{}{}
\newenvironment{argcontract}{}{}
\newenvironment{together}{}{}
\newenvironment{SBibliography}{}{}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Etc.
% 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}}
\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{\subsectionhidden}[1]{\subsection{#1}}
\newcommand{\subsubsectionhidden}[1]{\subsubsection{#1}}
\newenvironment{SCentered}{\begin{trivlist}\item \centering}{\end{trivlist}}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 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
(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
(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-struct resolve-info (ci delays undef searches))
(define-provide-syntax (compat-out stx)
(syntax-case stx ()
[(_ . outs) #'(compat**-out struct-out . outs)]))
(define (part-collected-info part ri)
(hash-ref (collect-info-parts (resolve-info-ci ri))
part))
(define-provide-syntax (compat*-out stx)
(syntax-case stx ()
[(_ . outs) #'(compat**-out struct*-out . outs)]))
(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))
(define-provide-syntax (struct*-out stx)
(syntax-case stx ()
[(_ [id (field-id ...)])
(with-syntax ([id? (datum->syntax #'id
(string->symbol (format "~a?" (syntax-e #'id)))
#'id)]
[struct:id (datum->syntax #'id
(string->symbol (format "struct:~a" (syntax-e #'id)))
#'id)]
[make-id (datum->syntax #'id
(string->symbol (format "make-~a" (syntax-e #'id)))
#'id)]
[(sel-id ...)
(map (lambda (field-id)
(datum->syntax field-id
(string->symbol (format "~a-~a" (syntax-e #'id) (syntax-e field-id)))
field-id))
(syntax->list #'(field-id ...)))])
#'(combine-out
id struct:id make-id id? sel-id ...))]
[(_ [id (field-id ...)]...)
#'(combine-out (struct*-out [id (field-id ...)]) ...)]))
(provide (struct-out collect-info)
(struct-out resolve-info))
(struct-out resolve-info)
tag? block?
make-flow flow? flow-paragraphs
;; ----------------------------------------
(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?
(provide provide-structs)
(except-out (compat-out paragraph) paragraph-content)
(rename-out [paragraph-content/compat paragraph-content])
make-styled-paragraph
(rename-out [paragraph? styled-paragraph?]
[paragraph-style styled-paragraph-style])
make-omitable-paragraph omitable-paragraph?
(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))))]))
(compat-out table)
table-flowss
make-auxiliary-table auxiliary-table?
(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))))
(struct-out delayed-block)
(provide block?)
(define (block? p)
(or (paragraph? p)
(table? p)
(itemization? p)
(blockquote? p)
(compound-paragraph? p)
(delayed-block? p)))
(compat-out itemization)
(rename-out [itemization-blockss itemization-flows]
[itemization? styled-itemization?]
[itemization-style styled-itemization-style])
make-styled-itemization
(define (string-without-newline? s)
(and (string? s)
(not (regexp-match? #rx"\n" s))))
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
[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]
[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?
(cons/c (one-of/c 'collects)
(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-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)])
(if (and (pair? l) (null? (cdr l)))
(car l)
(make-element #f l)))))))
#'deserialize-delayed-element
#f
(or (current-load-relative-directory) (current-directory))))
(define (list->content l)
(if (and (pair? l) (null? (cdr l)))
(car l)
l))
(provide/contract
(struct delayed-element ([resolve (any/c part? resolve-info? . -> . list?)]
[sizer (-> any)]
[plain (-> any)])))
(define (content->list v)
(if (list? v)
v
(list v)))
(provide deserialize-delayed-element)
(define deserialize-delayed-element
(make-deserialize-info values values))
(define (make-part/compat tag-prefix tags title-content orig-style to-collect flow parts)
(make-part tag-prefix
tags
(list->content title-content)
(convert-style orig-style)
to-collect
(flow-paragraphs flow)
parts))
(provide delayed-element-content)
(define (delayed-element-content e ri)
(hash-ref (resolve-info-delays ri) e))
(define (part-title-content/compat p)
(list (part-title-content p)))
(provide delayed-block-blocks)
(define (delayed-block-blocks p ri)
(hash-ref (resolve-info-delays ri) p))
(define (make-versioned-part tag-prefix tags title-content orig-style to-collect flow parts version)
(make-part tag-prefix
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 current-serialize-resolve-info (make-parameter #f))
(define (make-unnumbered-part tag-prefix tags title-content orig-style to-collect flow parts)
(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-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
(make-element #f (part-relative-element-content d ri))))))
#'deserialize-part-relative-element
#f
(or (current-load-relative-directory) (current-directory))))
(define (make-omitable-paragraph content)
(make-paragraph (make-style #f '(omitable)) (list->content content)))
(define (omitable-paragraph? p)
(and (paragraph? p) (memq 'omitable (style-variants (paragraph-style p)))))
(provide/contract
(struct part-relative-element ([collect (collect-info? . -> . list?)]
[sizer (-> any)]
[plain (-> any)])))
(define (make-table/compat style cellss)
(make-table (convert-style style)
(map (lambda (cells)
(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 deserialize-part-relative-element
(make-deserialize-info values values))
(define (make-auxiliary-table style cells)
(let ([t (make-table/compat style cells)])
(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 (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))
(define (auxiliary-table? t)
(ormap (lambda (v) (eq? v 'aux) (style-variants (table-style t)))))
(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.
;; 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))))
(define (make-compound-paragraph/compat style blocks)
(make-compound-paragraph (convert-style style) blocks))
(provide/contract
(struct delayed-index-desc ([resolve (any/c part? resolve-info? . -> . any)])))
(define (element-style-name s)
(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 deserialize-delayed-index-desc
(make-deserialize-info values values))
(define (add-element-variant v e)
(make-element (make-style (element-style-name (element-style e))
(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)
#: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)
(define (convert-element-style style)
(cond
[(null? content) null]
[(aux-element? (car content)) (strip-aux (cdr content))]
[else (cons (car content) (strip-aux (cdr content)))]))
[(not style) style]
[(string? style) style]
[(symbol? style) style]
[else (convert-style style)]))
;; ----------------------------------------
(provide block-width
element-width)
(define (element-width s)
(define (element?/compat e)
(or (element? e) (and (list? e) (content? e))))
(define (element-content/compat e)
(cond
[(string? s) (string-length s)]
[(element? s) (apply + (map element-width (element-content s)))]
[(delayed-element? s) (element-width ((delayed-element-sizer s)))]
[(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)
[(element? e) (content->list (element-content e))]
[else e]))
(define (element-style/compat e)
(cond
[(paragraph? p) (paragraph-width p)]
[(table? p) (table-width p)]
[(itemization? p) (itemization-width p)]
[(blockquote? p) (blockquote-width p)]
[(compound-paragraph? p) (compound-paragraph-width p)]
[(delayed-block? p) 1]))
[(element? e) (element-style e)]
[else #f]))
(define (table-width p)
(let ([flowss (table-flowss p)])
(if (null? flowss)
0
(let loop ([flowss flowss])
(if (null? (car flowss))
0
(+ (apply max 0 (map flow-width (map car flowss)))
(loop (map cdr flowss))))))))
(define (make-element/compat style content)
(handle-image-style make-element style (list->content content)))
(define (make-toc-element/compat style content toc-content)
(handle-image-style make-toc-element style (list->content content) (list->content toc-content)))
(define (toc-element-toc-content/compat e)
(content->list (toc-element-toc-content e)))
(define (make-target-element/compat style content tag)
(handle-image-style make-target-element style (list->content content) tag))
(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)
(apply max 0 (map flow-width (itemization-flows p))))
(define (make-aux-element style content)
(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)
(+ 4 (apply max 0 (map block-width (blockquote-paragraphs p)))))
(define (make-hover-element style content text)
(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)
(apply max 0 (map block-width (compound-paragraph-blocks p))))
(define (make-script-element style content type script)
(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 (part-style? p s)
(let ([st (part-style p)])
(or (eq? s st)
(and (list? st) (memq s st)))))
;; ----------------------------------------
(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)])
;; ----------------------------------------
(define (convert-style s)
(cond
[(not s) plain]
[(style? s) s]
[(string? s) (make-style s null)]
[(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))])
(make-style (style-name s)
(cons
(make-attributes (with-attributes-assoc wa))
(style-variants s))))]
[(target-url? s) (let ([s (convert-style (target-url-style s))])
(make-style (style-name s)
(cons
(core:make-target-url (target-url-addr s))
(style-variants s))))]
[(image-file? s) (make-style #f null)]
[(and (list? s) (pair? s) (eq? (car s) 'color))
(make-style #f (list (make-color-variant
(if (string? (cadr s)) (cadr s) (cdr s)))))]
[(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)
(cond
@ -568,5 +425,3 @@
(target-url-addr s)
rest)))]
[else s]))
(provide flatten-style)

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

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

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

@ -3,13 +3,14 @@
scribble/decode
scribble/eval
scribble/struct
scribble/scheme
(for-label htdp/convert
scheme/gui/base))
@(define (ioinputfont . s)
(apply tt 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}

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

@ -1,6 +1,5 @@
#lang scribble/doc
@(require scribble/manual
scribble/eval
#lang scribble/manual
@(require scribble/eval
"guide-utils.ss")
@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
represent filesystem paths, correctly manipulating a path can be
surprisingly difficult. For example, if you start under Unix with the
absolute path @file{/tmp/~} and take just the last part, you end up
with @file{~}---which looks like a reference to the current user's
absolute path @filepath{/tmp/~} and take just the last part, you end up
with @filepath{~}---which looks like a reference to the current user's
home directory, instead of a relative path to a file of directory
named @file{~}. Windows path manipulation, furthermore, is far
trickier, because path elements like @file{aux} can have special
named @filepath{~}. Windows path manipulation, furthermore, is far
trickier, because path elements like @filepath{aux} can have special
meanings.
@refdetails/gory["windows-path"]{Windows filesystem paths}

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

@ -1,6 +1,7 @@
#lang scribble/doc
@(require scribble/manual
scribble/eval
scribble/core
"guide-utils.ss")
@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
supported are
@itemize[#:style "compact"
@itemize[#:style (make-style "compact" null)
@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]
(define-signature toy-factory^
(build-toys (code:comment (integer? -> (listof toy?)))
repaint (code:comment (toy? symbol? -> toy?))
toy? (code:comment (any/c -> boolean?))
toy-color)) (code:comment (toy? -> symbol?))
(build-toys (code:comment #, @tt{(integer? -> (listof toy?))})
repaint (code:comment #, @tt{(toy? symbol? -> toy?)})
toy? (code:comment #, @tt{(any/c -> boolean?)})
toy-color)) (code:comment #, @tt{(toy? -> symbol?)})
(provide toy-factory^)
]
@ -101,9 +101,9 @@ is willing to sell only toys in a particular color.)
scheme]
(define-signature toy-store^
(store-color (code:comment (-> symbol?))
stock! (code:comment (integer? -> void?))
get-inventory)) (code:comment (-> (listof toy?)))
(store-color (code:comment #, @tt{(-> symbol?)})
stock! (code:comment #, @tt{(integer? -> void?)})
get-inventory)) (code:comment #, @tt{(-> (listof toy?))})
(provide toy-store^)
]
@ -420,10 +420,10 @@ For example, @filepath{toy-factory-sig.ss} can be written as
@schememod[
scheme/signature
build-toys (code:comment (integer? -> (listof toy?)))
repaint (code:comment (toy? symbol? -> toy?))
toy? (code:comment (any/c -> boolean?))
toy-color (code:comment (toy? -> symbol?))
build-toys (code:comment #, @tt{(integer? -> (listof toy?))})
repaint (code:comment #, @tt{(toy? symbol? -> toy?)})
toy? (code:comment #, @tt{(any/c -> boolean?)})
toy-color (code:comment #, @tt{(toy? -> symbol?)})
]
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
scribble/struct
scribble/decode
scribble/scheme
(for-syntax scheme/base)
(for-label scheme/base))
@ -140,7 +141,7 @@
(let ([d (resolve-get/tentative part ri `(cpp ,x))])
(list
(if d
(make-link-element "schemesyntaxlink" (list e) `(cpp ,x))
(make-link-element syntax-link-color (list e) `(cpp ,x))
e))))
(lambda () e)
(lambda () e)))

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

@ -4,7 +4,9 @@
(require scribble/decode
scribble/decode-struct
scribble/basic
scribble/struct
scribble/core
scribble/scheme
scribble/html-variants
scribble/manual-struct
scheme/list
scheme/string
@ -98,16 +100,16 @@
`(,@e ,(make-element "smaller"
`(" (method of "
,(make-element
"schemesymbol"
symbol-color
(list
(make-element
"schemevaluelink"
value-link-color
(list (symbol->string
(exported-index-desc-name desc))))))
")")))
e)]
[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'
[`((a ([href ,href] [class "indexlink"]) . ,body))
(cond [(and (part-index-desc? desc)
@ -181,12 +183,15 @@
(make-splice
(list
(make-paragraph
plain
(list
(script-ref "plt-index.js"
#:noscript
@list{Sorry, you must have JavaScript to use this page.})
(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)))))
(make-styled-paragraph '()
(make-with-attributes 'div '([id . "plt_search_container"]))))))
(make-paragraph (make-style #f
(list 'div
(make-attributes '([id . "plt_search_container"]))))
'()))))

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

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

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

@ -3,7 +3,8 @@
(require "../config.ss"
scribble/manual
scribble/struct
scribble/core
scribble/html-variants
scribble/decode
scheme/list
setup/dirs)
@ -17,10 +18,18 @@
[else (error 'main-page "page id not found: ~e" id)]))))
(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)
(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
;; 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
(regexp-replace* #rx"[^/]*/" (regexp-replace #rx"[^/]+$" path "") "../"))
(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
;; there's no way (currently) to not have it in the window title
@ -88,14 +105,14 @@
[else (error "internal error (main-page)")]))
(define (onclick style)
(if (eq? root 'user)
(make-with-attributes
style
`([onclick
. ,(format "return GotoPLTRoot(\"~a\", \"~a\");"
(version) path)]))
(make-style style
(list (make-attributes
`([onclick
. ,(format "return GotoPLTRoot(\"~a\", \"~a\");"
(version) path)]))))
style))
(define (elt style)
(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")))))
links))

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

@ -1,102 +1,102 @@
((1) 0 () 0 () () 5)
((1) 0 () 0 () () 5)
((1) 0 () 0 () () (c begin c "art gallery"))
((1) 0 () 0 () () "art gallery")
((1) 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]")))))
((1) 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]")))))
((1) 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"))
((1) 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]")))))
((1) 0 () 0 () () (c define c c c (c circle c 10)))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c define c r c (c rectangle c 10 c 20)))
((1) 0 () 0 () () (void))
((1) 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]")))))
((1) 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]")))))
((1) 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]")))))
((1) 0 () 0 () () (c define c (c square c n) c (c filled-rectangle c n c n)))
((1) 0 () 0 () () (void))
((1) 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]")))))
((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)))
((1) 0 () 0 () () (void))
((1) 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]")))))
((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))))
((1) 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")))
((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]")))))
((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))))
((1) 0 () 0 () () (void))
((1) 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]")))))
((1) 0 () 0 () () circle)
((1) 1 (((lib "scribble/struct.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))))
((1) 0 () 0 () () (void))
((1) 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]")))))
((1) 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]")))))
((1) 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]")))))
((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"))))))
((1) 0 () 0 () () (void))
((1) 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]")))))
((1) 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]")))))
((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")))))
((1) 0 () 0 () () (void))
((1) 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]")))))
((1) 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]")))))
((1) 0 () 0 () () (c list c "red" c "green" c "blue"))
((1) 0 () 0 () () (c "red" c "green" c "blue"))
((1) 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)))))))
((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"))))
((1) 0 () 0 () () (void))
((1) 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)))))))
((1) 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]")))))
((1) 0 () 0 () () (c require c slideshow/flash))
((1) 0 () 0 () () (void))
((1) 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]")))))
((1) 0 () 0 () () (c require c (c planet c "random.ss" c (c "schematics" c "random.plt" c 1 c 0))))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c random-gaussian))
((1) 0 () 0 () () 0.7386912134436788)
((1) 0 () 0 () () (c require c slideshow/code))
((1) 0 () 0 () () (void))
((1) 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]")))))
((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))))))
((1) 0 () 0 () () (void))
((1) 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]")))))
((1) 0 () 0 () () (c require c scheme/class c scheme/gui/base))
((1) 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))))))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c send c f c show c #t))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c send c f c show c #f))
((1) 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)))))))
((1) 0 () 0 () () (void))
((1) 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% ...)"))))
((1) 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% ...)"))))
((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))
((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) 0 () 0 () () 5)
((2) 0 () 0 () () 5)
((2) 0 () 0 () () (c begin c "art gallery"))
((2) 0 () 0 () () "art gallery")
((2) 0 () 0 () () (c circle c 10))
((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))
((2) 0 () 0 () () (c rectangle c 10 c 20))
((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))
((2) 0 () 0 () () (c circle c 10 c 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"))
((2) 0 () 0 () () (c hc-append c (c circle c 10) c (c rectangle c 10 c 20)))
((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))
((2) 0 () 0 () () (c define c c c (c circle c 10)))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c define c r c (c rectangle c 10 c 20)))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () r)
((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))
((2) 0 () 0 () () (c hc-append c c c r))
((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))
((2) 0 () 0 () () (c hc-append c 20 c c c r c c))
((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))
((2) 0 () 0 () () (c define c (c square c n) c (c filled-rectangle c n c n)))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c square c 10))
((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))
((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)))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c four c (c circle c 10)))
((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))
((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))))
((2) 0 () 0 () () (void))
((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")))
((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))
((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))))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c checkerboard c (c square c 10)))
((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))
((2) 0 () 0 () () circle)
((2) 1 (((lib "scribble/core.ss") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#<procedure:circle>"))))
((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))))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c series c circle))
((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))
((2) 0 () 0 () () (c series c square))
((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))
((2) 0 () 0 () () (c series c (c lambda c (c size) c (c checkerboard c (c square c size)))))
((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))
((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"))))))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c rgb-series c circle))
((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))
((2) 0 () 0 () () (c rgb-series c square))
((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))
((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")))))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c series c (c rgb-maker c circle)))
((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))
((2) 0 () 0 () () (c series c (c rgb-maker c square)))
((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))
((2) 0 () 0 () () (c list c "red" c "green" c "blue"))
((2) 0 () 0 () () (c "red" c "green" c "blue"))
((2) 0 () 0 () () (c list c (c circle c 10) c (c square c 10)))
((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)))
((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"))))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c rainbow c (c square c 5)))
((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)))
((2) 0 () 0 () () (c apply c vc-append c (c rainbow c (c square c 5))))
((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))
((2) 0 () 0 () () (c require c slideshow/flash))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c filled-flash c 40 c 30))
((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))
((2) 0 () 0 () () (c require c (c planet c "random.ss" c (c "schematics" c "random.plt" c 1 c 0))))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c random-gaussian))
((2) 0 () 0 () () 0.7386912134436788)
((2) 0 () 0 () () (c require c slideshow/code))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c code c (c circle c 10)))
((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))
((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))))))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c pict+code c (c circle c 10)))
((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))
((2) 0 () 0 () () (c require c scheme/class c scheme/gui/base))
((2) 0 () 0 () () (void))
((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))))))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c send c f c show c #t))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c send c f c show c #f))
((2) 0 () 0 () () (void))
((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)))))))
((2) 0 () 0 () () (void))
((2) 0 () 0 () () (c add-drawing c (c pict+code c (c circle c 10))))
((2) 1 (((lib "scribble/core.ss") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)"))))
((2) 0 () 0 () () (c add-drawing c (c colorize c (c filled-flash c 50 c 30) c "yellow")))
((2) 1 (((lib "scribble/core.ss") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)"))))
((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))
((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"?>
<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: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='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='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='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:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<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='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='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>
</x:xmpmeta>
@ -55,8 +55,8 @@ endstream
endobj
2 0 obj
<</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155146-07'00')
/ModDate(D:20090303155146-07'00')
/CreationDate(D:20090722182600-06'00')
/ModDate(D:20090722182600-06'00')
/Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref
@ -73,7 +73,7 @@ xref
0000000640 00000 n
trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<5B9C18337FC8389A1DFF2A1017EF4F38><5B9C18337FC8389A1DFF2A1017EF4F38>]
/ID [<359940CD83EE8F3FC014C34CE1255CDE><359940CD83EE8F3FC014C34CE1255CDE>]
>>
startxref
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"?>
<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: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='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='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='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:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<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='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='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>
</x:xmpmeta>
@ -55,8 +55,8 @@ endstream
endobj
2 0 obj
<</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155146-07'00')
/ModDate(D:20090303155146-07'00')
/CreationDate(D:20090722182601-06'00')
/ModDate(D:20090722182601-06'00')
/Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref
@ -73,7 +73,7 @@ xref
0000000577 00000 n
trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<D1DCD84F7619933E209882189C123385><D1DCD84F7619933E209882189C123385>]
/ID [<B544940615DB98AEC7D1DC63F54A451E><B544940615DB98AEC7D1DC63F54A451E>]
>>
startxref
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"?>
<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: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='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='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='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:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<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='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='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>
</x:xmpmeta>
@ -55,8 +55,8 @@ endstream
endobj
2 0 obj
<</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155147-07'00')
/ModDate(D:20090303155147-07'00')
/CreationDate(D:20090722182602-06'00')
/ModDate(D:20090722182602-06'00')
/Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref
@ -73,7 +73,7 @@ xref
0000000588 00000 n
trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<1AE0C6090561E21FACDD570510EAE550><1AE0C6090561E21FACDD570510EAE550>]
/ID [<3F728FBF71FC3EE42151B158C78C6E47><3F728FBF71FC3EE42151B158C78C6E47>]
>>
startxref
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"?>
<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: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='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='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='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:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<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='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='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>
</x:xmpmeta>
@ -57,8 +57,8 @@ endstream
endobj
2 0 obj
<</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155144-07'00')
/ModDate(D:20090303155144-07'00')
/CreationDate(D:20090722182558-06'00')
/ModDate(D:20090722182558-06'00')
/Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref
@ -75,7 +75,7 @@ xref
0000000546 00000 n
trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<390C745AD3529AFF7AA2F07ADD0F632F><390C745AD3529AFF7AA2F07ADD0F632F>]
/ID [<BF3BAD7CB407F5E17AE00BD540FA6C1B><BF3BAD7CB407F5E17AE00BD540FA6C1B>]
>>
startxref
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"?>
<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: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='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='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='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:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<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='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='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>
</x:xmpmeta>
@ -56,8 +56,8 @@ endstream
endobj
2 0 obj
<</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155149-07'00')
/ModDate(D:20090303155149-07'00')
/CreationDate(D:20090722182604-06'00')
/ModDate(D:20090722182604-06'00')
/Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref
@ -74,7 +74,7 @@ xref
0000000577 00000 n
trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<D47DD8E8F4F6B70E9917B60988320218><D47DD8E8F4F6B70E9917B60988320218>]
/ID [<F1ECA86EA72818308D60B49648AD980D><F1ECA86EA72818308D60B49648AD980D>]
>>
startxref
2215

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

@ -42,10 +42,10 @@ endobj
<?adobe-xap-filters esc="CRLF"?>
<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: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='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='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='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:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<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='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='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>
</x:xmpmeta>
@ -55,8 +55,8 @@ endstream
endobj
2 0 obj
<</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155149-07'00')
/ModDate(D:20090303155149-07'00')
/CreationDate(D:20090722182604-06'00')
/ModDate(D:20090722182604-06'00')
/Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref
@ -73,7 +73,7 @@ xref
0000000622 00000 n
trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<BE08CA6AB9E961B083F33BBF7F8A8E2B><BE08CA6AB9E961B083F33BBF7F8A8E2B>]
/ID [<5B1279F9960652F0F9499AE6C2394568><5B1279F9960652F0F9499AE6C2394568>]
>>
startxref
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"?>
<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: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='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='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='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:pdf='http://ns.adobe.com/pdf/1.3/' pdf:Producer='GPL Ghostscript 8.63'/>
<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='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='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>
</x:xmpmeta>
@ -57,8 +57,8 @@ endstream
endobj
2 0 obj
<</Producer(GPL Ghostscript 8.63)
/CreationDate(D:20090303155144-07'00')
/ModDate(D:20090303155144-07'00')
/CreationDate(D:20090722182559-06'00')
/ModDate(D:20090722182559-06'00')
/Creator(PLT Scheme)
/Author(mflatt@Macintosh \(Matthew Flatt\))>>endobj
xref
@ -75,7 +75,7 @@ xref
0000000546 00000 n
trailer
<< /Size 10 /Root 1 0 R /Info 2 0 R
/ID [<A95CA727A37F788F07D908E7B89358F0><A95CA727A37F788F07D908E7B89358F0>]
/ID [<6E7272D6B2731DC8CB2BE347FB5EA742><6E7272D6B2731DC8CB2BE347FB5EA742>]
>>
startxref
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)
(make-render-element
(make-element #f (list))
#f
null
(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
@(require scribble/struct
scribble/scheme
"mz.ss")
@(define (cont n)
(make-element "schemevariable"
(make-element variable-color
(list "C" (make-element 'subscript (list (format "~a" n))))))
@title[#:tag "contmarks"]{Continuation Marks}

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

@ -1,5 +1,6 @@
#lang scribble/doc
@(require scribble/struct
scribble/scheme
(for-syntax scheme/base)
"mz.ss"
"prog-steps.ss")
@ -8,7 +9,7 @@
@(define rspace (make-element "ghost" (list 'rarr)))
@(define *redex (lambda (c)
(make-element "highlighted" (list c))))
(make-element highlighted-color (list c))))
@(define-syntax redex
(syntax-rules () [(_ a) (*redex (scheme a))]))
@ -18,7 +19,7 @@
@(define-syntax sub
(syntax-rules () [(_ a b) (*sub (scheme a) (scheme b))]))
@(define (frame n)
(make-element "schemevariable"
(make-element variable-color
(list "C" (make-element 'subscript (list (format "~a" n))))))
@;{
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
@(require "mz.ss"
scribble/struct
scribble/core
scribble/html-variants
(for-label scheme/help
net/url
scheme/gui))
@; Beware of this hard-wired link to the main doc page:
@(define main-doc-page
(link "../index.html"
#:style (make-with-attributes
"plainlink"
`((onclick . ,(format "return GotoPLTRoot(\"~a\");" (version)))))
"main documentation page"))
(hyperlink "../index.html"
#:style (make-style
"plainlink"
(list
(make-attributes
`((onclick . ,(format "return GotoPLTRoot(\"~a\");" (version)))))))
"main documentation page"))
@title{Interactive Help}

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

@ -8,7 +8,7 @@
(provide parse-match-grammar)
(define (match-nonterm s)
(make-element "schemevariable" (list s)))
(make-element variable-color (list s)))
(define (fixup s middle)
(lambda (m)
@ -67,15 +67,15 @@
(match-nonterm (symbol->string s))]
[(QUOTE LIST LIST-REST LIST-NO-ORDER VECTOR HASH-TABLE BOX STRUCT
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 "schemesymbol" '("___"))]
(make-element symbol-color '("..."))]
[(___) (make-element symbol-color '("___"))]
[(__K)
(make-element #f (list (make-element "schemesymbol" '("__"))
(make-element #f (list (make-element symbol-color '("__"))
(match-nonterm "k")))]
[(..K)
(make-element #f (list (make-element "schemesymbol" '(".."))
(make-element #f (list (make-element symbol-color '(".."))
(match-nonterm "k")))]
[else
s])]

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