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

Do not actually use dependent contracts in provide/doc if there is no dependency

Browse Source 
original commit: 334978a8e42347ef0db5480fe6c959ca90cb3bb9
This commit is contained in:
Jay McCarthy 2010-07-15 09:52:30 -06:00
commit 5c2c949a7c
20 changed files with 458 additions and 230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/help/search.rkt
View File

@ -21,7 +21,7 @@
;; running a browser on local files (like NEU). If you use this, then ;; running a browser on local files (like NEU). If you use this, then
;; it is a good idea to put the documentation tree somewhere local, to ;; it is a good idea to put the documentation tree somewhere local, to
;; have better interaction times and not overload the PLT server. ;; have better interaction times and not overload the PLT server.
;; (define doc-url "http://download.racket-lang.org/doc/4.1/html/") ;; (define doc-url "http://download.racket-lang.org/docs/5.0/html/")
;; (define (send-main-page #:sub [sub "index.html"] ;; (define (send-main-page #:sub [sub "index.html"]
;; #:fragment [fragment #f] #:query [query #f]) ;; #:fragment [fragment #f] #:query [query #f])
;; (define (part pfx x) (if x (list pfx x) '())) ;; (define (part pfx x) (if x (list pfx x) '()))

3
collects/meta/web/html/html.rkt
View File

@ -170,8 +170,7 @@
(provide style/inline) (provide style/inline)
(define (style/inline . args) (define (style/inline . args)
(let-values ([(attrs body) (attributes+body args)]) (let-values ([(attrs body) (attributes+body args)])
(make-element 'style attrs (make-element 'style attrs `("\n" ,body "\n"))))
`("\n" ,(apply comment #:newlines? #t body) "\n"))))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; Entities ;; Entities

85
collects/meta/web/html/resource.rkt
View File

@ -35,36 +35,50 @@
;; the currently rendered directory, as a list ;; the currently rendered directory, as a list
(define rendered-dirpath (make-parameter '())) (define rendered-dirpath (make-parameter '()))
;; a mapping from path prefixes to urls (actually, any string) -- when two ;; A mapping from path prefixes to urls (actually, any string) -- when two
;; paths are in the same prefix, links from one to the other are relative, but ;; paths are in the same prefix, links from one to the other are relative, but
;; if they're in different prefixes, the url will be used instead; the roots ;; if they're in different prefixes, the url will be used instead; the roots
;; are expected to be disjoint (= no "/foo" and "/foo/bar" roots) ;; are expected to be disjoint (= no "/foo" and "/foo/bar" roots).
;; Additionally, optional symbol flags can appear in each entry, currently only
;; 'abs is used below for roots that should always use absolute links (needed
;; for some skeleton pages that are used in nested subdirectories).
(provide url-roots) (provide url-roots)
(define url-roots (define url-roots (make-parameter #f))
;; takes in a (listof (list prefix-string url-string)), and produces an alist
;; with lists of strings for the keys; the prefix-strings are split on "/"s, (define cached-roots '(#f . #f))
;; and the url-strings can be anything at all actually (they are put as-is (define (current-url-roots)
;; before the path with a "/" between them) ;; takes in a (listof (list prefix-string url-string . flags)), and produces
(make-parameter #f ;; an alist with lists of strings for the keys; the prefix-strings are split
(lambda (x) ;; on "/"s, and the url-strings can be anything at all actually (they are put
(and (list? x) (pair? x) ;; as-is before the path with a "/" between them).
(map (lambda (x) (let ([roots (url-roots)])
(cons (regexp-match* #rx"[^/]+" (car x)) (unless (eq? roots (car cached-roots))
(regexp-replace #rx"/$" (cadr x) ""))) (set! cached-roots
x))))) (cons roots
(and (list? roots) (pair? roots)
(map (lambda (root)
(list* (regexp-match* #rx"[^/]+" (car root))
(regexp-replace #rx"/$" (cadr root) "")
(cddr root)))
roots)))))
(cdr cached-roots)))
;; a utility for relative paths, taking the above `default-file' and ;; a utility for relative paths, taking the above `default-file' and
;; `url-roots' into consideration. ;; `url-roots' into consideration.
(define (relativize file tgtdir curdir) (define (relativize file tgtdir curdir)
(define file* (if (equal? file default-file) "" file)) (define file* (if (equal? file default-file) "" file))
(define roots (url-roots)) (define roots (current-url-roots))
(define (make-rooted path) (define (find-root path mode)
(ormap (lambda (root+url) (ormap (lambda (root+url+flags)
(let loop ([r (car root+url)] [p path]) (let loop ([r (car root+url+flags)] [p path])
(if (null? r) (if (pair? r)
`(,(cdr root+url) ,@p ,file*)
(and (pair? p) (equal? (car p) (car r)) (and (pair? p) (equal? (car p) (car r))
(loop (cdr r) (cdr p)))))) (loop (cdr r) (cdr p)))
(case mode
[(get-path) `(,(cadr root+url+flags) ,@p ,file*)]
[(get-abs-or-true)
(if (memq 'abs (cddr root+url+flags)) `("" ,@p) #t)]
[else (error 'relativize "internal error: ~e" mode)]))))
roots)) roots))
(define result (define result
(let loop ([t tgtdir] [c curdir] [pfx '()]) (let loop ([t tgtdir] [c curdir] [pfx '()])
@ -73,13 +87,17 @@
[(and (pair? t) (pair? c) (equal? (car t) (car c))) [(and (pair? t) (pair? c) (equal? (car t) (car c)))
(loop (cdr t) (cdr c) (cons (car t) pfx))] (loop (cdr t) (cdr c) (cons (car t) pfx))]
;; done ;; done
[(or (not roots) ; if there are no roots ;; no roots => always use a relative path (useful for debugging)
(make-rooted (reverse pfx))) ; or if they share a root [(not roots) `(,@(map (lambda (_) "..") c) ,@t ,file*)]
;; then make them relative ;; share a root => use a relative path unless its an absolute root
`(,@(map (lambda (_) "..") c) ,@t ,file*)] [(find-root (reverse pfx) 'get-abs-or-true)
=> (lambda (abs/true)
`(;; rel. => as above
,@(if (list? abs/true) abs/true (map (lambda (_) "..") c))
,@t ,file*))]
;; different roots => use the one for the target ;; different roots => use the one for the target
[(make-rooted t)] [(find-root tgtdir 'get-path)]
;; otherwise throw an error ;; if there isn't any, throw an error
[else (error 'relativize "target url is not in any known root: ~a" [else (error 'relativize "target url is not in any known root: ~a"
(string-join `(,@tgtdir ,file*) "/"))]))) (string-join `(,@tgtdir ,file*) "/"))])))
(if (equal? '("") result) "." (string-join result "/"))) (if (equal? '("") result) "." (string-join result "/")))
@ -127,7 +145,10 @@
(R "index.html" '() '("x" "y")) =error> "not in any" (R "index.html" '() '("x" "y")) =error> "not in any"
(R "index.html" '("x") '("x" "y")) => "../" (R "index.html" '("x") '("x" "y")) => "../"
(R "index.html" '("x" "y") '("x" "y")) => "." (R "index.html" '("x" "y") '("x" "y")) => "."
(R "index.html" '("x" "y") '("y" "x")) => "/X/y/")))) (R "index.html" '("x" "y") '("y" "x")) => "/X/y/"))
do (parameterize ([url-roots '(["/x" "/X/"] ["/y" "/Y/" abs])])
(test (R "foo.txt" '("x" "1") '("x" "2")) => "../1/foo.txt"
(R "foo.txt" '("y" "1") '("y" "2")) => "/1/foo.txt"))))
|# |#
;; utility for keeping a list of renderer thunks ;; utility for keeping a list of renderer thunks
@ -179,7 +200,13 @@
(add-renderer path render) (add-renderer path render)
(make-keyword-procedure (make-keyword-procedure
(lambda (kws kvs . args) (keyword-apply referrer kws kvs (url) args)) (lambda (kws kvs . args) (keyword-apply referrer kws kvs (url) args))
(lambda args (apply referrer (url) args))))) (case-lambda [(x) (if (eq? x get-resource-path) (url) (referrer (url) x))]
[args (apply referrer (url) args)]))))
;; make it possible to always get the path to a resource
(provide get-resource-path)
(define (get-resource-path resource)
(resource get-resource-path))
;; a convenient utility to create renderers from some output function (like ;; a convenient utility to create renderers from some output function (like
;; `output-xml' or `display') and some content ;; `output-xml' or `display') and some content

15
collects/meta/web/html/xml.rkt
View File

@ -2,7 +2,7 @@
;; XML-like objects and functions, with rendering ;; XML-like objects and functions, with rendering
(require scribble/text) (require scribble/text racket/port)
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; Represent attribute names as `foo:' symbols. They are made self-quoting in ;; Represent attribute names as `foo:' symbols. They are made self-quoting in
@ -37,6 +37,15 @@
"missing attribute value for `~s:'" a)] "missing attribute value for `~s:'" a)]
[else (loop (cddr xs) (cons (cons a (cadr xs)) as))])))) [else (loop (cddr xs) (cons (cons a (cadr xs)) as))]))))
;; similar, but keeps the attributes as a list, useful to build new functions
;; that accept attributes without knowing about the xml structs.
(provide split-attributes+body)
(define (split-attributes+body xs)
(let loop ([xs xs] [as '()])
(if (and (pair? xs) (pair? (cdr xs)) (attribute->symbol (car xs)))
(loop (cddr xs) (list* (cadr xs) (car xs) as))
(values (reverse as) xs))))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; An output that handles xml quoting, customizable ;; An output that handles xml quoting, customizable
@ -61,6 +70,10 @@
(define (output-xml content [p (current-output-port)]) (define (output-xml content [p (current-output-port)])
(output (disable-prefix (with-writer (xml-writer) content)) p)) (output (disable-prefix (with-writer (xml-writer) content)) p))
(provide xml->string)
(define (xml->string content)
(with-output-to-string (lambda () (output-xml content))))
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; Structs for xml data: elements, literals, entities ;; Structs for xml data: elements, literals, entities

1
collects/scribble/decode.rkt
View File

@ -295,6 +295,7 @@
(append-map (lambda (s) (cond (append-map (lambda (s) (cond
[(string? s) (decode-string s)] [(string? s) (decode-string s)]
[(void? s) null] [(void? s) null]
[(splice? s) (decode-content (splice-run s))]
[else (list s)])) [else (list s)]))
(skip-whitespace l))) (skip-whitespace l)))

6
collects/scribble/doclang.rkt
View File

@ -1,11 +1,11 @@
#lang scheme/base #lang racket/base
(require "struct.ss" (require "struct.ss"
"decode.ss" "decode.ss"
(for-syntax scheme/base (for-syntax racket/base
syntax/kerncase)) syntax/kerncase))
(provide (except-out (all-from-out scheme/base) #%module-begin) (provide (except-out (all-from-out racket/base) #%module-begin)
(rename-out [*module-begin #%module-begin])) (rename-out [*module-begin #%module-begin]))
;; Module wrapper ---------------------------------------- ;; Module wrapper ----------------------------------------

2
collects/scribble/private/manual-bib.rkt
View File

@ -65,7 +65,7 @@
(if date `(" " ,@(decode-content (list date)) ".") null) (if date `(" " ,@(decode-content (list date)) ".") null)
(if url `(" " ,(link url (tt url))) null))))) (if url `(" " ,(link url (tt url))) null)))))
(define-on-demand bib-style (make-style "SBibliography" scheme-properties)) (define-on-demand bib-style (make-style "RBibliography" scheme-properties))
(define (bibliography #:tag [tag "doc-bibliography"] . citations) (define (bibliography #:tag [tag "doc-bibliography"] . citations)
(make-unnumbered-part (make-unnumbered-part

4
collects/scribble/private/manual-sprop.rkt
View File

@ -11,5 +11,5 @@
(define-on-demand scheme-properties (define-on-demand scheme-properties
(let ([abs (lambda (s) (let ([abs (lambda (s)
(path->main-collects-relative (build-path (collection-path "scribble") s)))]) (path->main-collects-relative (build-path (collection-path "scribble") s)))])
(list (make-css-addition (abs "scheme.css")) (list (make-css-addition (abs "racket.css"))
(make-tex-addition (abs "scheme.tex"))))) (make-tex-addition (abs "racket.tex")))))

8
collects/scribble/private/manual-style.rkt
View File

@ -217,17 +217,17 @@
(define (filebox filename . inside) (define (filebox filename . inside)
(make-nested-flow (make-nested-flow
(make-style "Sfilebox" scheme-properties) (make-style "Rfilebox" scheme-properties)
(list (list
(make-styled-paragraph (make-styled-paragraph
(list (make-element (list (make-element
(make-style "Sfilename" scheme-properties) (make-style "Rfilename" scheme-properties)
(if (string? filename) (if (string? filename)
(filepath filename) (filepath filename)
filename))) filename)))
(make-style "Sfiletitle" scheme-properties)) (make-style "Rfiletitle" scheme-properties))
(make-nested-flow (make-nested-flow
(make-style "Sfilecontent" scheme-properties) (make-style "Rfilecontent" scheme-properties)
(decode-flow inside))))) (decode-flow inside)))))

56
collects/scribble/scheme.css → collects/scribble/racket.css
View File

@ -2,9 +2,9 @@
/* See the beginning of "scribble.css". */ /* See the beginning of "scribble.css". */
/* Monospace: */ /* Monospace: */
.ScmIn, .ScmRdr, .ScmPn, .ScmMeta, .RktIn, .RktRdr, .RktPn, .RktMeta,
.ScmMod, .ScmKw, .ScmVar, .ScmSym, .RktMod, .RktKw, .RktVar, .RktSym,
.ScmRes, .ScmOut, .ScmCmt, .ScmVal { .RktRes, .RktOut, .RktCmt, .RktVal {
font-family: monospace; font-family: monospace;
} }
@ -35,84 +35,84 @@
} }
/* ---------------------------------------- */ /* ---------------------------------------- */
/* Scheme text styles */ /* Racket text styles */
.ScmIn { .RktIn {
color: #cc6633; color: #cc6633;
background-color: #eeeeee; background-color: #eeeeee;
} }
.ScmInBG { .RktInBG {
background-color: #eeeeee; background-color: #eeeeee;
} }
.ScmRdr { .RktRdr {
} }
.ScmPn { .RktPn {
color: #843c24; color: #843c24;
} }
.ScmMeta { .RktMeta {
color: black; color: black;
} }
.ScmMod { .RktMod {
color: black; color: black;
} }
.ScmOpt { .RktOpt {
color: black; color: black;
} }
.ScmKw { .RktKw {
color: black; color: black;
font-weight: bold; font-weight: bold;
} }
.ScmErr { .RktErr {
color: red; color: red;
font-style: italic; font-style: italic;
} }
.ScmVar { .RktVar {
color: #262680; color: #262680;
font-style: italic; font-style: italic;
} }
.ScmSym { .RktSym {
color: #262680; color: #262680;
} }
.ScmValLink { .RktValLink {
text-decoration: none; text-decoration: none;
color: blue; color: blue;
} }
.ScmModLink { .RktModLink {
text-decoration: none; text-decoration: none;
color: blue; color: blue;
} }
.ScmStxLink { .RktStxLink {
text-decoration: none; text-decoration: none;
color: black; color: black;
font-weight: bold; font-weight: bold;
} }
.ScmRes { .RktRes {
color: #0000af; color: #0000af;
} }
.ScmOut { .RktOut {
color: #960096; color: #960096;
} }
.ScmCmt { .RktCmt {
color: #c2741f; color: #c2741f;
} }
.ScmVal { .RktVal {
color: #228b22; color: #228b22;
} }
@ -130,7 +130,7 @@
vertical-align: bottom; vertical-align: bottom;
} }
.ScmBlk td { .RktBlk td {
vertical-align: baseline; vertical-align: baseline;
} }
@ -151,7 +151,7 @@
float: right; float: right;
} }
.SBibliography td { .RBibliography td {
vertical-align: text-top; vertical-align: text-top;
} }
@ -165,17 +165,17 @@
margin-right: 1em; margin-right: 1em;
} }
.Sfilebox { .Rfilebox {
margin-left: 1em; margin-left: 1em;
margin-right: 1em; margin-right: 1em;
} }
.Sfiletitle { .Rfiletitle {
text-align: right; text-align: right;
margin: 0em 0em 0em 0em; margin: 0em 0em 0em 0em;
} }
.Sfilename { .Rfilename {
border-top: 1px solid #6C8585; border-top: 1px solid #6C8585;
border-right: 1px solid #6C8585; border-right: 1px solid #6C8585;
padding-left: 0.5em; padding-left: 0.5em;
@ -183,6 +183,6 @@
background-color: #ECF5F5; background-color: #ECF5F5;
} }
.Sfilecontent { .Rfilecontent {
margin: 0em 0em 0em 0em; margin: 0em 0em 0em 0em;
} }

40
collects/scribble/racket.rkt
View File

@ -58,26 +58,26 @@
(cons 'tt-chars scheme-properties) (cons 'tt-chars scheme-properties)
scheme-properties))) scheme-properties)))
(define-on-demand output-color (make-racket-style "ScmOut")) (define-on-demand output-color (make-racket-style "RktOut"))
(define-on-demand input-color (make-racket-style "ScmIn")) (define-on-demand input-color (make-racket-style "RktIn"))
(define-on-demand input-background-color (make-racket-style "ScmInBG")) (define-on-demand input-background-color (make-racket-style "RktInBG"))
(define-on-demand no-color (make-racket-style "ScmPlain")) (define-on-demand no-color (make-racket-style "RktPlain"))
(define-on-demand reader-color (make-racket-style "ScmRdr")) (define-on-demand reader-color (make-racket-style "RktRdr"))
(define-on-demand result-color (make-racket-style "ScmRes")) (define-on-demand result-color (make-racket-style "RktRes"))
(define-on-demand keyword-color (make-racket-style "ScmKw")) (define-on-demand keyword-color (make-racket-style "RktKw"))
(define-on-demand comment-color (make-racket-style "ScmCmt")) (define-on-demand comment-color (make-racket-style "RktCmt"))
(define-on-demand paren-color (make-racket-style "ScmPn")) (define-on-demand paren-color (make-racket-style "RktPn"))
(define-on-demand meta-color (make-racket-style "ScmMeta")) (define-on-demand meta-color (make-racket-style "RktMeta"))
(define-on-demand value-color (make-racket-style "ScmVal")) (define-on-demand value-color (make-racket-style "RktVal"))
(define-on-demand symbol-color (make-racket-style "ScmSym")) (define-on-demand symbol-color (make-racket-style "RktSym"))
(define-on-demand variable-color (make-racket-style "ScmVar")) (define-on-demand variable-color (make-racket-style "RktVar"))
(define-on-demand opt-color (make-racket-style "ScmOpt")) (define-on-demand opt-color (make-racket-style "RktOpt"))
(define-on-demand error-color (make-racket-style "ScmErr" #:tt? #f)) (define-on-demand error-color (make-racket-style "RktErr" #:tt? #f))
(define-on-demand syntax-link-color (make-racket-style "ScmStxLink")) (define-on-demand syntax-link-color (make-racket-style "RktStxLink"))
(define-on-demand value-link-color (make-racket-style "ScmValLink")) (define-on-demand value-link-color (make-racket-style "RktValLink"))
(define-on-demand module-color (make-racket-style "ScmMod")) (define-on-demand module-color (make-racket-style "RktMod"))
(define-on-demand module-link-color (make-racket-style "ScmModLink")) (define-on-demand module-link-color (make-racket-style "RktModLink"))
(define-on-demand block-color (make-racket-style "ScmBlk")) (define-on-demand block-color (make-racket-style "RktBlk"))
(define-on-demand highlighted-color (make-racket-style "highlighted" #:tt? #f)) (define-on-demand highlighted-color (make-racket-style "highlighted" #:tt? #f))
(define current-keyword-list (define current-keyword-list

58
collects/scribble/racket.tex Normal file
View File

@ -0,0 +1,58 @@
% 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{\RktPlain}[1]{\inColor{black}{#1}}
\newcommand{\RktKw}[1]{{\SColorize{black}{\Scribtexttt{\textbf{#1}}}}}
\newcommand{\RktStxLink}[1]{\RktKw{#1}}
\newcommand{\RktCmt}[1]{\inColor{CommentColor}{#1}}
\newcommand{\RktPn}[1]{\inColor{ParenColor}{#1}}
\newcommand{\RktInBG}[1]{\inColor{ParenColor}{#1}}
\newcommand{\RktSym}[1]{\inColor{IdentifierColor}{#1}}
\newcommand{\RktVal}[1]{\inColor{ValueColor}{#1}}
\newcommand{\RktValLink}[1]{\inColor{blue}{#1}}
\newcommand{\RktModLink}[1]{\inColor{blue}{#1}}
\newcommand{\RktRes}[1]{\inColor{ResultColor}{#1}}
\newcommand{\RktOut}[1]{\inColor{OutputColor}{#1}}
\newcommand{\RktMeta}[1]{\inColor{IdentifierColor}{#1}}
\newcommand{\RktMod}[1]{\inColor{black}{#1}}
\newcommand{\RktRdr}[1]{\inColor{black}{#1}}
\newcommand{\RktVarCol}[1]{\inColor{IdentifierColor}{#1}}
\newcommand{\RktVar}[1]{{\RktVarCol{\textsl{#1}}}}
\newcommand{\RktErrCol}[1]{\inColor{red}{#1}}
\newcommand{\RktErr}[1]{{\RktErrCol{\textrm{\textit{#1}}}}}
\newcommand{\RktOpt}[1]{#1}
\newcommand{\RktIn}[1]{\incolorbox{LightGray}{\RktInBG{#1}}}
\newcommand{\highlighted}[1]{\colorbox{PaleBlue}{\hspace{-0.5ex}\RktInBG{#1}\hspace{-0.5ex}}}
\newenvironment{RktBlk}{}{}
\newenvironment{defmodule}{}{}
\newenvironment{prototype}{}{}
\newenvironment{argcontract}{}{}
\newenvironment{together}{}{}
\newenvironment{specgrammar}{}{}
\newenvironment{RBibliography}{}{}
\newcommand{\bibentry}[1]{\parbox[t]{0.8\linewidth}{#1}}
\newenvironment{leftindent}{\begin{quote}}{\end{quote}}
\newenvironment{insetpara}{\begin{quote}}{\end{quote}}
\newcommand{\Rfiletitle}[1]{\hfill \fbox{#1}}
\newcommand{\Rfilename}[1]{#1}
\newenvironment{Rfilebox}{\begin{list}{}{\topsep=0pt\partopsep=0pt%
\listparindent=0pt\itemindent=0pt\labelwidth=0pt\leftmargin=2ex\rightmargin=2ex%
\itemsep=0pt\parsep=0pt}\item}{\end{list}}
\newenvironment{Rfilecontent}{}{}

42
collects/scribble/sigplan.rkt
View File

@ -1,5 +1,6 @@
#lang scheme/base #lang scheme/base
(require setup/main-collects (require setup/main-collects
scheme/contract
scribble/core scribble/core
scribble/base scribble/base
scribble/decode scribble/decode
@ -7,11 +8,35 @@
scribble/latex-properties scribble/latex-properties
(for-syntax scheme/base)) (for-syntax scheme/base))
(provide/contract
[abstract
(->* () () #:rest (listof pre-content?)
block?)]
[authorinfo
(-> pre-content? pre-content? pre-content?
block?)]
[conferenceinfo
(-> pre-content? pre-content?
block?)]
[copyrightyear
(->* () () #:rest (listof pre-content?)
block?)]
[copyrightdata
(->* () () #:rest (listof pre-content?)
block?)]
[category
(->* (pre-content? pre-content? pre-content?)
((or/c false/c pre-content?))
content?)]
[terms
(->* () () #:rest (listof pre-content?)
content?)]
[keywords
(->* () () #:rest (listof pre-content?)
content?)])
(provide preprint 10pt (provide preprint 10pt
abstract include-abstract include-abstract)
authorinfo
conferenceinfo copyrightyear copyrightdata
category terms keywords)
(define-syntax (preprint stx) (define-syntax (preprint stx)
(raise-syntax-error #f (raise-syntax-error #f
@ -97,11 +122,10 @@
(define (category sec title sub [more #f]) (define (category sec title sub [more #f])
(make-multiarg-element (make-multiarg-element
(make-style (format "SCategory~a" (if more "Plus" "")) sigplan-extras) (make-style (format "SCategory~a" (if more "Plus" "")) sigplan-extras)
(append (list*
(list (make-element #f (decode-content (list sec)))
(make-element #f (decode-content (list sec))) (make-element #f (decode-content (list title)))
(make-element #f (decode-content (list title))) (make-element #f (decode-content (list sub)))
(make-element #f (decode-content (list sub))))
(if more (if more
(list (make-element #f (decode-content (list more)))) (list (make-element #f (decode-content (list more))))
null)))) null))))

37
collects/scribble/srcdoc.rkt
View File

@ -57,18 +57,33 @@
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ id contract desc) [(_ id contract desc)
(with-syntax ([(header result (body-stuff ...)) (with-syntax ([(header result (body-stuff ...) better-contract)
(syntax-case #'contract (->d -> values) (syntax-case #'contract (->d -> values)
[(->d (req ...) () (values [name res] ...)) [(->d ([arg-id arg/c] ...) () (values [name res] ...))
#'((id req ...) (values res ...) ())] #'((id [arg-id arg/c] ...)
(values res ...)
()
(-> arg/c ... (values res ...)))]
[(->d (req ...) () #:pre-cond condition (values [name res] ...)) [(->d (req ...) () #:pre-cond condition (values [name res] ...))
#'((id req ...) (values res ...) ((bold "Pre-condition: ") (scheme condition) "\n" "\n"))] #'((id req ...)
[(->d (req ...) () [name res]) (values res ...)
#'((id req ...) res ())] ((bold "Pre-condition: ") (scheme condition) "\n" "\n")
contract)]
[(->d ([arg-id arg/c] ...) () [name res])
#'((id [arg-id arg/c] ...)
res
()
(-> arg/c ... res))]
[(->d (req ...) () #:pre-cond condition [name res]) [(->d (req ...) () #:pre-cond condition [name res])
#'((id req ...) res ((bold "Pre-condition: ") (scheme condition) "\n" "\n" ))] #'((id req ...)
[(->d (req ...) () #:rest rest rest-ctc [name res]) res
#'((id req ... [rest rest-ctc] (... ...)) res ())] ((bold "Pre-condition: ") (scheme condition) "\n" "\n" )
contract)]
[(->d ([arg-id arg/c] ...) () #:rest rest rest-ctc [name res])
#'((id [arg-id arg/c] ... [rest rest-ctc] (... ...))
res
()
(->* (arg/c ...) () #:rest rest-ctc res))]
[(->d (req ...) (one more ...) whatever) [(->d (req ...) (one more ...) whatever)
(raise-syntax-error (raise-syntax-error
#f #f
@ -83,7 +98,7 @@
stx stx
#'contract)] #'contract)]
[(-> result) [(-> result)
#'((id) result ())] #'((id) result () contract)]
[(-> whatever ...) [(-> whatever ...)
(raise-syntax-error (raise-syntax-error
#f #f
@ -98,7 +113,7 @@
stx stx
#'contract)])]) #'contract)])])
(values (values
#'[id contract] #'[id better-contract]
#'(defproc header result body-stuff ... . desc) #'(defproc header result body-stuff ... . desc)
#'(scribble/manual) #'(scribble/manual)
#'id))]))) #'id))])))

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

@ -141,7 +141,7 @@ expressions.
}===| }===|
The command part of an @"@"-form is optional as well. In that case, The command part of an @"@"-form is optional as well. In that case,
the @"@" forms is read as a list, which usually counts as a function the @"@" form is read as a list, which usually counts as a function
application, but it also useful when quoted with the usual Racket application, but it also useful when quoted with the usual Racket
@racket[quote]: @racket[quote]:

6
collects/scribblings/scribble/sigplan.scrbl
View File

@ -65,9 +65,9 @@ Declares information that is collected into the copyright region of the paper.}
@defproc[(category [CR-number pre-content?] @defproc[(category [CR-number pre-content?]
[subcategory pre-content?] [subcategory pre-content?]
[third-level pre-content?] [third-level pre-content?]
[fourth-level (or/c #f pre-content?) #f]) block?] [fourth-level (or/c #f pre-content?) #f]) content?]
@defproc[(terms [content pre-content?] ...) block?] @defproc[(terms [content pre-content?] ...) content?]
@defproc[(keywords [content pre-content?] ...) block?] @defproc[(keywords [content pre-content?] ...) content?]
)]{ )]{
Typesets category, term, and keyword information for the paper, which Typesets category, term, and keyword information for the paper, which

48
collects/scriblib/autobib.rkt
View File

@ -1,4 +1,4 @@
#lang at-exp scheme/base #lang at-exp racket/base
(require scribble/manual (require scribble/manual
scribble/core scribble/core
scribble/decode scribble/decode
@ -41,6 +41,25 @@
(lambda () "(???)") (lambda () "(???)")
(lambda () "(???)"))) (lambda () "(???)")))
(define (add-inline-cite group bib-entries)
(for ([i bib-entries]) (hash-set! (bib-group-ht group) i #t))
(when (and (pair? (cdr bib-entries)) (not (apply equal? (map auto-bib-author bib-entries))))
(error 'citet "citet must be used with identical authors, given ~a" (map auto-bib-author bib-entries)))
(make-element
#f
(list (add-cite group (car bib-entries) 'autobib-author)
'nbsp
"("
(let loop ([keys bib-entries])
(if (null? (cdr keys))
(add-cite group (car keys) 'autobib-date)
(make-element
#f
(list (loop (list (car keys)))
"; "
(loop (cdr keys))))))
")")))
(define (add-cites group bib-entries) (define (add-cites group bib-entries)
(make-element (make-element
#f #f
@ -48,7 +67,12 @@
"(" "("
(let loop ([keys bib-entries]) (let loop ([keys bib-entries])
(if (null? (cdr keys)) (if (null? (cdr keys))
(add-cite group (car keys) 'autobib-cite) (make-element
#f
(list
(add-cite group (car keys) 'autobib-author)
" "
(add-cite group (car keys) 'autobib-date)))
(make-element (make-element
#f #f
(list (loop (list (car keys))) (list (loop (list (car keys)))
@ -87,23 +111,17 @@
`(autobib ,(auto-bib-key k)))) `(autobib ,(auto-bib-key k))))
(lambda (ci) (lambda (ci)
(collect-put! ci (collect-put! ci
`(autobib-cite ,(auto-bib-key k)) `(autobib-author ,(auto-bib-key k))
(make-element (make-element
#f #f
(list (list
(author-element-cite (auto-bib-author k)) (author-element-cite (auto-bib-author k)))))
" "
(auto-bib-date k))))
(collect-put! ci (collect-put! ci
`(autobib-inline ,(auto-bib-key k)) `(autobib-date ,(auto-bib-key k))
(make-element (make-element
#f #f
(list (list
(author-element-cite (auto-bib-author k)) (auto-bib-date k))))))))))
'nbsp
"("
(auto-bib-date k)
")")))))))))
bibs))) bibs)))
null))) null)))
@ -112,8 +130,8 @@
(define group (make-bib-group (make-hasheq))) (define group (make-bib-group (make-hasheq)))
(define (~cite bib-entry . bib-entries) (define (~cite bib-entry . bib-entries)
(add-cites group (cons bib-entry bib-entries))) (add-cites group (cons bib-entry bib-entries)))
(define (citet bib-entry) (define (citet bib-entry . bib-entries)
(add-cite group bib-entry 'autobib-inline)) (add-inline-cite group (cons bib-entry bib-entries)))
(define (generate-bibliography #:tag [tag "doc-bibliography"]) (define (generate-bibliography #:tag [tag "doc-bibliography"])
(gen-bib tag group)))) (gen-bib tag group))))
@ -171,7 +189,7 @@
(if (author-element? a) (if (author-element? a)
a a
(let* ([s (content->string a)] (let* ([s (content->string a)]
[m (regexp-match #px"^(.*) (\\p{L}+)$" s)]) [m (regexp-match #px"^(.*) (([\\-]|\\p{L})+)$" s)])
(make-author-element (make-author-element
#f #f
(list a) (list a)

185
collects/scriblib/gui-eval.rkt
View File

@ -8,21 +8,40 @@
racket/runtime-path racket/runtime-path
racket/serialize racket/serialize
"private/gui-eval-exn.ss" "private/gui-eval-exn.ss"
racket/system) racket/system
(for-syntax racket/base))
(define-syntax define-mr (define-syntax define-mr
(syntax-rules () (syntax-rules ()
[(_ mr orig) [(_ mr orig)
(begin (begin
(provide mr) (provide mr)
(define-syntax mr (define-syntax (mr stx)
(syntax-rules () (syntax-case stx ()
[(_ #:eval+opts the-eval get-predicate? get-render get-get-width get-get-height x (... ...))
#'(let ([the-eval-x the-eval])
(parameterize ([scribble-eval-handler (gui-eval-handler the-eval-x
get-predicate?
get-render
get-get-width
get-get-height)])
(orig #:eval the-eval-x x (... ...))))]
[(_ x (... ...)) [(_ x (... ...))
(parameterize ([scribble-eval-handler gui-eval-handler]) #'(parameterize ([scribble-eval-handler (gui-eval-handler gui-eval
(orig #:eval gui-eval x (... ...)))])))])) (λ () (gui-eval 'pict?))
(λ () (gui-eval 'draw-pict))
(λ () (gui-eval 'pict-width))
(λ () (gui-eval 'pict-height)))])
(orig #:eval gui-eval x (... ...)))])))]))
(define gui-eval (make-base-eval)) (define gui-eval (make-base-eval))
(define mred? (getenv "MREVAL"))
(when mred?
(gui-eval '(require racket/gui/base))
(gui-eval '(require slideshow)))
(define-mr gui-interaction interaction) (define-mr gui-interaction interaction)
(define-mr gui-interaction-eval interaction-eval) (define-mr gui-interaction-eval interaction-eval)
(define-mr gui-interaction-eval-show interaction-eval-show) (define-mr gui-interaction-eval-show interaction-eval-show)
@ -34,12 +53,6 @@
(provide (rename-out [gui-racketmod+eval gui-schememod+eval] (provide (rename-out [gui-racketmod+eval gui-schememod+eval]
[gui-racketblock+eval gui-schemeblock+eval])) [gui-racketblock+eval gui-schemeblock+eval]))
(define mred? (getenv "MREVAL"))
(when mred?
(gui-eval '(require racket/gui/base))
(gui-eval '(require slideshow)))
;; This one needs to be relative, because it ends up in the ;; This one needs to be relative, because it ends up in the
;; exprs.dat file: ;; exprs.dat file:
(define img-dir "images") ; relative to src dir (define img-dir "images") ; relative to src dir
@ -52,16 +65,20 @@
(if mred? (if mred?
(let ([eh (scribble-eval-handler)] (let ([eh (scribble-eval-handler)]
[log-file (open-output-file exprs-dat-file #:exists 'truncate/replace)]) [log-file (open-output-file exprs-dat-file #:exists 'truncate/replace)])
(lambda (ev catching-exns? expr) (λ (gui-eval get-predicate? get-render get-get-width get-get-height)
(write (serialize (if (syntax? expr) (syntax->datum expr) expr)) log-file) (lambda (ev catching-exns? expr)
(newline log-file) (write (serialize (if (syntax? expr) (syntax->datum expr) expr)) log-file)
(flush-output log-file) (newline log-file)
(let ([result (flush-output log-file)
(with-handlers ([exn:fail? (let ([result
(lambda (exn) (with-handlers ([exn:fail?
(make-gui-exn (exn-message exn)))]) (lambda (exn)
(eh ev catching-exns? expr))]) (make-gui-exn (exn-message exn)))])
(let ([result (fixup-picts result)]) ;; put the call to fixup-picts in the handlers
;; so that errors in the user-supplied predicates &
;; conversion functions show up in the rendered output
(fixup-picts (get-predicate?) (get-render) (get-get-width) (get-get-height)
(eh ev catching-exns? expr)))])
(write (serialize result) log-file) (write (serialize result) log-file)
(newline log-file) (newline log-file)
(flush-output log-file) (flush-output log-file)
@ -74,71 +91,73 @@
(lambda (exn) (lambda (exn)
(open-input-string ""))]) (open-input-string ""))])
(open-input-file exprs-dat-file))]) (open-input-file exprs-dat-file))])
(lambda (ev catching-exns? expr) (λ (gui-eval get-predicate? get-render get-get-width get-get-height)
(with-handlers ([exn:fail? (lambda (exn) (lambda (ev catching-exns? expr)
(if catching-exns? (with-handlers ([exn:fail? (lambda (exn)
(raise exn) (if catching-exns?
(void)))]) (raise exn)
(let ([v (read log-file)]) (void)))])
(if (eof-object? v) (let ([v (read log-file)])
(error "expression not in log file") (if (eof-object? v)
(let ([v (deserialize v)]) (error "expression not in log file")
(if (equal? v (if (syntax? expr) (let ([v (deserialize v)])
(syntax->datum expr) (if (equal? v (if (syntax? expr)
expr)) (syntax->datum expr)
(let ([v (read log-file)]) expr))
(if (eof-object? v) (let ([v (read log-file)])
(error "expression result missing in log file") (if (eof-object? v)
(let ([v (deserialize v)]) (error "expression result missing in log file")
(if (gui-exn? v) (let ([v (deserialize v)])
(raise (make-exn:fail (if (gui-exn? v)
(gui-exn-message v) (raise (make-exn:fail
(current-continuation-marks))) (gui-exn-message v)
v)))) (current-continuation-marks)))
(error 'mreval v))))
"expression does not match log file: ~e versus: ~e" (error 'mreval
expr "expression does not match log file: ~e versus: ~e"
v)))))))))) expr
v)))))))))))
(define image-counter 0) (define image-counter 0)
;; This path will be marshaled for use on multiple platforms ;; This path will be marshaled for use on multiple platforms
(define (build-string-path a b) (string-append a "/" b)) (define (build-string-path a b) (string-append a "/" b))
(define (fixup-picts v) (define (fixup-picts predicate? render get-width get-height v)
(cond (let loop ([v v])
[((gui-eval 'pict?) v) (cond
(let ([fn (build-string-path img-dir [(predicate? v)
(format "img~a.png" image-counter))]) (let ([fn (build-string-path img-dir
(set! image-counter (add1 image-counter)) (format "img~a.png" image-counter))])
(let ([dc (let ([pss (make-object (gui-eval 'ps-setup%))]) (set! image-counter (add1 image-counter))
(send pss set-mode 'file) (let ([dc (let ([pss (make-object (gui-eval 'ps-setup%))])
(send pss set-file (path-replace-suffix fn #".ps")) (send pss set-mode 'file)
(parameterize ([(gui-eval 'current-ps-setup) pss]) (send pss set-file (path-replace-suffix fn #".ps"))
(make-object (gui-eval 'post-script-dc%) #f)))]) (parameterize ([(gui-eval 'current-ps-setup) pss])
(send dc start-doc "Image") (make-object (gui-eval 'post-script-dc%) #f)))])
(send dc start-page) (send dc start-doc "Image")
(((gui-eval 'make-pict-drawer) v) dc 0 0) (send dc start-page)
(send dc end-page) (render v dc 0 0)
(send dc end-doc) (send dc end-page)
(system (format "epstopdf ~a" (path-replace-suffix fn #".ps")))) (send dc end-doc)
(let* ([bm (make-object (gui-eval 'bitmap%) (system (format "epstopdf ~a" (path-replace-suffix fn #".ps"))))
(inexact->exact (ceiling ((gui-eval 'pict-width) v))) (let* ([bm (make-object (gui-eval 'bitmap%)
(inexact->exact (ceiling ((gui-eval 'pict-height) v))))] (inexact->exact (ceiling (get-width v)))
[dc (make-object (gui-eval 'bitmap-dc%) bm)]) (inexact->exact (ceiling (get-height v))))]
(send dc set-smoothing 'aligned) [dc (make-object (gui-eval 'bitmap-dc%) bm)])
(send dc clear) (send dc set-smoothing 'aligned)
(((gui-eval 'make-pict-drawer) v) dc 0 0) (send dc clear)
(send bm save-file fn 'png) (render v dc 0 0)
(make-image-element (send bm save-file fn 'png)
#f (make-image-element
(list "[image]") #f
;; Be sure to use a string rather than a path, because (list "[image]")
;; it gets recorded in "exprs.dat". ;; Be sure to use a string rather than a path, because
(path->string (path-replace-suffix fn #"")) ;; it gets recorded in "exprs.dat".
'(".pdf" ".png") (path->string (path-replace-suffix fn #""))
1.0)))] '(".pdf" ".png")
[(pair? v) (cons (fixup-picts (car v)) 1.0)))]
(fixup-picts (cdr v)))] [(pair? v) (cons (loop (car v))
[(serializable? v) v] (loop (cdr v)))]
[else (make-element #f (list (format "~s" v)))])) [(serializable? v) v]
[else (make-element #f (list (format "~s" v)))])))

21
collects/scriblib/scribblings/autobib.scrbl
View File

@ -22,16 +22,21 @@ Binds @scheme[~cite-id], @scheme[citet-id], and
@scheme[generate-bibliography-id], which share state to accumulate and @scheme[generate-bibliography-id], which share state to accumulate and
render citations. render citations.
The function bound to @scheme[~cite-id] produces a citation with a The function bound to @scheme[~cite-id] produces a citation referring
preceding non-breaking space. It has the contract to one or more bibliography entries with a preceding non-breaking
space. It has the contract
@schemeblock[ @schemeblock[
((bib?) () (listof bib?) . ->* . element?) ((bib?) () (listof bib?) . ->* . element?)
] ]
The function bound to @scheme[citet-id] has the same contract as the The function bound to @scheme[citet-id] generates an element suitable
function for @scheme[~cite-id], but it generates an element suitable for use as a noun---referring to a document or its author---for one
for use as a noun refering to the document or its author. or more bibliography entries which share an author. It has the contract
@schemeblock[
((bib?) () (listof bib?) . ->* . element?)
]
The function bound to @scheme[generate-bibliography-id] generates the The function bound to @scheme[generate-bibliography-id] generates the
section for the bibliography. It has the contract section for the bibliography. It has the contract
@ -65,9 +70,9 @@ standard format.
An element produced by a function like @scheme[author-name] tracks An element produced by a function like @scheme[author-name] tracks
first, last names, and name suffixes separately, so that names can be first, last names, and name suffixes separately, so that names can be
ordered and rendered correctly. When a string is provided as an author ordered and rendered correctly. When a string is provided as an author
name, the last non-empty sequence of ASCII alphabetic characters after name, the last non-empty sequence of alphabetic characters or
a space is treated as the author name, and the rest is treated as the @litchar["-"] after a space is treated as the author name, and the
first name.} rest is treated as the first name.}
@defproc[(in-bib [orig bib?] [where string?]) bib?]{ @defproc[(in-bib [orig bib?] [where string?]) bib?]{

67
collects/scriblib/scribblings/gui-eval.scrbl
View File

@ -16,16 +16,65 @@ images. Future runs (with the environment variable unset) use the
generated image. generated image.
@deftogether[( @deftogether[(
@defform[(gui-interaction datum ...)] @defform*[((gui-interaction datum ...)
@defform[(gui-interaction-eval datum ...)] (gui-interaction
@defform[(gui-interaction-eval-show datum ...)] #:eval+opts the-eval get-predicate? get-render
@defform[(gui-schemeblock+eval datum ...)] get-get-width get-get-height
@defform[(gui-schememod+eval datum ...)] datum ...))
@defform[(gui-def+int datum ...)] ]
@defform[(gui-defs+int datum ...)] @defform*[((gui-interaction-eval datum ...)
(gui-interaction-eval
#:eval+opts the-eval get-predicate? get-render
get-get-width get-get-height
datum ... ))]
@defform*[((gui-interaction-eval-show datum ...)
(gui-interaction-eval-show
#:eval+opts the-eval get-predicate? get-render
get-get-width get-get-height
datum ...))]
@defform*[((gui-schemeblock+eval datum ...)
(gui-schemeblock+eval
#:eval+opts the-eval get-predicate? get-render
get-get-width get-get-height
datum ...))]
@defform*[((gui-schememod+eval datum ...)
(gui-schememod+eval
#:eval+opts the-eval get-predicate? get-render
get-get-width get-get-height
datum ...))]
@defform*[((gui-def+int datum ...)
(gui-def+int
#:eval+opts the-eval get-predicate? get-render
get-get-width get-get-height
datum ...))]
@defform*[((gui-defs+int datum ...)
(gui-defs+int
#:eval+opts the-eval get-predicate? get-render
get-get-width get-get-height
datum ...))]
)]{ )]{
Like @scheme[interaction], etc., but actually evaluating the forms The first option of each of the above is
like @scheme[interaction], etc., but actually evaluating the forms
only when the @envvar{MREVAL} environment variable is set, and then in only when the @envvar{MREVAL} environment variable is set, and then in
an evaluator that is initialized with @schememodname[racket/gui/base] an evaluator that is initialized with @schememodname[racket/gui/base]
and @schememodname[slideshow]. } and @schememodname[slideshow].
The second option of each allows you to specify your own evaluator via
the @scheme[the-eval] argument and then to specify four thunks that
return functions for finding and rendering graphical objects:
@itemize[
@item{@scheme[get-predicate? : (-> (-> any/c boolean?))]
Determines if a value is a graphical object (and thus handled by the other operations)}
@item{@scheme[get-render : (-> (-> any/c (is-a?/c dc<%>) number? number? void?))]
Draws a graphical object (only called if the predicate returned @scheme[#t]; the first
argument will be the value for which the predicate holds).}
@item{@scheme[get-get-width : (-> (-> any/c number?))]
Gets the width of a graphical object (only called if the predicate returned @scheme[#t]; the first
argument will be the value for which the predicate holds).}
@item{@scheme[get-get-height : (-> (-> any/c number?))]
Gets the height of a graphical object (only called if the predicate returned @scheme[#t]; the first
argument will be the value for which the predicate holds).}
]
}