commit 5c2c949a7c57625ca8c1229d5ff4c8630d157bcb
parent ef73afe8aa283ed2966b9cee72477958e7e901ed
Author: Jay McCarthy <jay@racket-lang.org>
Date: Thu, 15 Jul 2010 09:52:30 -0600
Do not actually use dependent contracts in provide/doc if there is no dependency
original commit: 334978a8e42347ef0db5480fe6c959ca90cb3bb9
Diffstat:
21 files changed, 618 insertions(+), 390 deletions(-)
diff --git a/collects/help/search.rkt b/collects/help/search.rkt
@@ -21,7 +21,7 @@
;; 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
;; 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"]
;; #:fragment [fragment #f] #:query [query #f])
;; (define (part pfx x) (if x (list pfx x) '()))
diff --git a/collects/meta/web/html/html.rkt b/collects/meta/web/html/html.rkt
@@ -170,8 +170,7 @@
(provide style/inline)
(define (style/inline . args)
(let-values ([(attrs body) (attributes+body args)])
- (make-element 'style attrs
- `("\n" ,(apply comment #:newlines? #t body) "\n"))))
+ (make-element 'style attrs `("\n" ,body "\n"))))
;; ----------------------------------------------------------------------------
;; Entities
diff --git a/collects/meta/web/html/resource.rkt b/collects/meta/web/html/resource.rkt
@@ -35,36 +35,50 @@
;; the currently rendered directory, as a list
(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
;; 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)
-(define url-roots
- ;; 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,
- ;; and the url-strings can be anything at all actually (they are put as-is
- ;; before the path with a "/" between them)
- (make-parameter #f
- (lambda (x)
- (and (list? x) (pair? x)
- (map (lambda (x)
- (cons (regexp-match* #rx"[^/]+" (car x))
- (regexp-replace #rx"/$" (cadr x) "")))
- x)))))
+(define url-roots (make-parameter #f))
+
+(define cached-roots '(#f . #f))
+(define (current-url-roots)
+ ;; takes in a (listof (list prefix-string url-string . flags)), and produces
+ ;; an alist with lists of strings for the keys; the prefix-strings are split
+ ;; on "/"s, and the url-strings can be anything at all actually (they are put
+ ;; as-is before the path with a "/" between them).
+ (let ([roots (url-roots)])
+ (unless (eq? roots (car cached-roots))
+ (set! cached-roots
+ (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
;; `url-roots' into consideration.
(define (relativize file tgtdir curdir)
(define file* (if (equal? file default-file) "" file))
- (define roots (url-roots))
- (define (make-rooted path)
- (ormap (lambda (root+url)
- (let loop ([r (car root+url)] [p path])
- (if (null? r)
- `(,(cdr root+url) ,@p ,file*)
+ (define roots (current-url-roots))
+ (define (find-root path mode)
+ (ormap (lambda (root+url+flags)
+ (let loop ([r (car root+url+flags)] [p path])
+ (if (pair? 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))
(define result
(let loop ([t tgtdir] [c curdir] [pfx '()])
@@ -73,13 +87,17 @@
[(and (pair? t) (pair? c) (equal? (car t) (car c)))
(loop (cdr t) (cdr c) (cons (car t) pfx))]
;; done
- [(or (not roots) ; if there are no roots
- (make-rooted (reverse pfx))) ; or if they share a root
- ;; then make them relative
- `(,@(map (lambda (_) "..") c) ,@t ,file*)]
+ ;; no roots => always use a relative path (useful for debugging)
+ [(not roots) `(,@(map (lambda (_) "..") c) ,@t ,file*)]
+ ;; share a root => use a relative path unless its an absolute root
+ [(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
- [(make-rooted t)]
- ;; otherwise throw an error
+ [(find-root tgtdir 'get-path)]
+ ;; if there isn't any, throw an error
[else (error 'relativize "target url is not in any known root: ~a"
(string-join `(,@tgtdir ,file*) "/"))])))
(if (equal? '("") result) "." (string-join result "/")))
@@ -127,7 +145,10 @@
(R "index.html" '() '("x" "y")) =error> "not in any"
(R "index.html" '("x") '("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
@@ -179,7 +200,13 @@
(add-renderer path render)
(make-keyword-procedure
(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
;; `output-xml' or `display') and some content
diff --git a/collects/meta/web/html/xml.rkt b/collects/meta/web/html/xml.rkt
@@ -2,7 +2,7 @@
;; 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
@@ -37,6 +37,15 @@
"missing attribute value for `~s:'" a)]
[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
@@ -61,6 +70,10 @@
(define (output-xml content [p (current-output-port)])
(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
diff --git a/collects/scribble/decode.rkt b/collects/scribble/decode.rkt
@@ -295,6 +295,7 @@
(append-map (lambda (s) (cond
[(string? s) (decode-string s)]
[(void? s) null]
+ [(splice? s) (decode-content (splice-run s))]
[else (list s)]))
(skip-whitespace l)))
diff --git a/collects/scribble/doclang.rkt b/collects/scribble/doclang.rkt
@@ -1,11 +1,11 @@
-#lang scheme/base
+#lang racket/base
(require "struct.ss"
"decode.ss"
- (for-syntax scheme/base
+ (for-syntax racket/base
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]))
;; Module wrapper ----------------------------------------
diff --git a/collects/scribble/private/manual-bib.rkt b/collects/scribble/private/manual-bib.rkt
@@ -65,7 +65,7 @@
(if date `(" " ,@(decode-content (list date)) ".") 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)
(make-unnumbered-part
diff --git a/collects/scribble/private/manual-sprop.rkt b/collects/scribble/private/manual-sprop.rkt
@@ -11,5 +11,5 @@
(define-on-demand scheme-properties
(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")))))
+ (list (make-css-addition (abs "racket.css"))
+ (make-tex-addition (abs "racket.tex")))))
diff --git a/collects/scribble/private/manual-style.rkt b/collects/scribble/private/manual-style.rkt
@@ -217,17 +217,17 @@
(define (filebox filename . inside)
(make-nested-flow
- (make-style "Sfilebox" scheme-properties)
+ (make-style "Rfilebox" scheme-properties)
(list
(make-styled-paragraph
(list (make-element
- (make-style "Sfilename" scheme-properties)
+ (make-style "Rfilename" scheme-properties)
(if (string? filename)
(filepath filename)
filename)))
- (make-style "Sfiletitle" scheme-properties))
+ (make-style "Rfiletitle" scheme-properties))
(make-nested-flow
- (make-style "Sfilecontent" scheme-properties)
+ (make-style "Rfilecontent" scheme-properties)
(decode-flow inside)))))
diff --git a/collects/scribble/racket.css b/collects/scribble/racket.css
@@ -0,0 +1,188 @@
+
+/* See the beginning of "scribble.css". */
+
+/* Monospace: */
+.RktIn, .RktRdr, .RktPn, .RktMeta,
+.RktMod, .RktKw, .RktVar, .RktSym,
+.RktRes, .RktOut, .RktCmt, .RktVal {
+ 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;
+}
+
+/* ---------------------------------------- */
+/* Racket text styles */
+
+.RktIn {
+ color: #cc6633;
+ background-color: #eeeeee;
+}
+
+.RktInBG {
+ background-color: #eeeeee;
+}
+
+.RktRdr {
+}
+
+.RktPn {
+ color: #843c24;
+}
+
+.RktMeta {
+ color: black;
+}
+
+.RktMod {
+ color: black;
+}
+
+.RktOpt {
+ color: black;
+}
+
+.RktKw {
+ color: black;
+ font-weight: bold;
+}
+
+.RktErr {
+ color: red;
+ font-style: italic;
+}
+
+.RktVar {
+ color: #262680;
+ font-style: italic;
+}
+
+.RktSym {
+ color: #262680;
+}
+
+.RktValLink {
+ text-decoration: none;
+ color: blue;
+}
+
+.RktModLink {
+ text-decoration: none;
+ color: blue;
+}
+
+.RktStxLink {
+ text-decoration: none;
+ color: black;
+ font-weight: bold;
+}
+
+.RktRes {
+ color: #0000af;
+}
+
+.RktOut {
+ color: #960096;
+}
+
+.RktCmt {
+ color: #c2741f;
+}
+
+.RktVal {
+ color: #228b22;
+}
+
+/* ---------------------------------------- */
+/* Some inline styles */
+
+.together {
+ width: 100%;
+}
+
+.prototype td {
+ vertical-align: text-top;
+}
+.longprototype td {
+ vertical-align: bottom;
+}
+
+.RktBlk td {
+ vertical-align: baseline;
+}
+
+.argcontract td {
+ vertical-align: text-top;
+}
+
+.highlighted {
+ background-color: #ddddff;
+}
+
+.defmodule {
+ width: 100%;
+ background-color: #F5F5DC;
+}
+
+.specgrammar {
+ float: right;
+}
+
+.RBibliography td {
+ vertical-align: text-top;
+}
+
+.leftindent {
+ margin-left: 1em;
+ margin-right: 0em;
+}
+
+.insetpara {
+ margin-left: 1em;
+ margin-right: 1em;
+}
+
+.Rfilebox {
+ margin-left: 1em;
+ margin-right: 1em;
+}
+
+.Rfiletitle {
+ text-align: right;
+ margin: 0em 0em 0em 0em;
+}
+
+.Rfilename {
+ border-top: 1px solid #6C8585;
+ border-right: 1px solid #6C8585;
+ padding-left: 0.5em;
+ padding-right: 0.5em;
+ background-color: #ECF5F5;
+}
+
+.Rfilecontent {
+ margin: 0em 0em 0em 0em;
+}
diff --git a/collects/scribble/racket.rkt b/collects/scribble/racket.rkt
@@ -58,26 +58,26 @@
(cons 'tt-chars scheme-properties)
scheme-properties)))
- (define-on-demand output-color (make-racket-style "ScmOut"))
- (define-on-demand input-color (make-racket-style "ScmIn"))
- (define-on-demand input-background-color (make-racket-style "ScmInBG"))
- (define-on-demand no-color (make-racket-style "ScmPlain"))
- (define-on-demand reader-color (make-racket-style "ScmRdr"))
- (define-on-demand result-color (make-racket-style "ScmRes"))
- (define-on-demand keyword-color (make-racket-style "ScmKw"))
- (define-on-demand comment-color (make-racket-style "ScmCmt"))
- (define-on-demand paren-color (make-racket-style "ScmPn"))
- (define-on-demand meta-color (make-racket-style "ScmMeta"))
- (define-on-demand value-color (make-racket-style "ScmVal"))
- (define-on-demand symbol-color (make-racket-style "ScmSym"))
- (define-on-demand variable-color (make-racket-style "ScmVar"))
- (define-on-demand opt-color (make-racket-style "ScmOpt"))
- (define-on-demand error-color (make-racket-style "ScmErr" #:tt? #f))
- (define-on-demand syntax-link-color (make-racket-style "ScmStxLink"))
- (define-on-demand value-link-color (make-racket-style "ScmValLink"))
- (define-on-demand module-color (make-racket-style "ScmMod"))
- (define-on-demand module-link-color (make-racket-style "ScmModLink"))
- (define-on-demand block-color (make-racket-style "ScmBlk"))
+ (define-on-demand output-color (make-racket-style "RktOut"))
+ (define-on-demand input-color (make-racket-style "RktIn"))
+ (define-on-demand input-background-color (make-racket-style "RktInBG"))
+ (define-on-demand no-color (make-racket-style "RktPlain"))
+ (define-on-demand reader-color (make-racket-style "RktRdr"))
+ (define-on-demand result-color (make-racket-style "RktRes"))
+ (define-on-demand keyword-color (make-racket-style "RktKw"))
+ (define-on-demand comment-color (make-racket-style "RktCmt"))
+ (define-on-demand paren-color (make-racket-style "RktPn"))
+ (define-on-demand meta-color (make-racket-style "RktMeta"))
+ (define-on-demand value-color (make-racket-style "RktVal"))
+ (define-on-demand symbol-color (make-racket-style "RktSym"))
+ (define-on-demand variable-color (make-racket-style "RktVar"))
+ (define-on-demand opt-color (make-racket-style "RktOpt"))
+ (define-on-demand error-color (make-racket-style "RktErr" #:tt? #f))
+ (define-on-demand syntax-link-color (make-racket-style "RktStxLink"))
+ (define-on-demand value-link-color (make-racket-style "RktValLink"))
+ (define-on-demand module-color (make-racket-style "RktMod"))
+ (define-on-demand module-link-color (make-racket-style "RktModLink"))
+ (define-on-demand block-color (make-racket-style "RktBlk"))
(define-on-demand highlighted-color (make-racket-style "highlighted" #:tt? #f))
(define current-keyword-list
diff --git a/collects/scribble/racket.tex b/collects/scribble/racket.tex
@@ -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}{}{}
diff --git a/collects/scribble/scheme.css b/collects/scribble/scheme.css
@@ -1,188 +0,0 @@
-
-/* 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: black;
-}
-
-.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;
-}
-
-.Sfilebox {
- margin-left: 1em;
- margin-right: 1em;
-}
-
-.Sfiletitle {
- text-align: right;
- margin: 0em 0em 0em 0em;
-}
-
-.Sfilename {
- border-top: 1px solid #6C8585;
- border-right: 1px solid #6C8585;
- padding-left: 0.5em;
- padding-right: 0.5em;
- background-color: #ECF5F5;
-}
-
-.Sfilecontent {
- margin: 0em 0em 0em 0em;
-}
diff --git a/collects/scribble/sigplan.rkt b/collects/scribble/sigplan.rkt
@@ -1,5 +1,6 @@
#lang scheme/base
(require setup/main-collects
+ scheme/contract
scribble/core
scribble/base
scribble/decode
@@ -7,11 +8,35 @@
scribble/latex-properties
(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
- abstract include-abstract
- authorinfo
- conferenceinfo copyrightyear copyrightdata
- category terms keywords)
+ include-abstract)
(define-syntax (preprint stx)
(raise-syntax-error #f
@@ -97,11 +122,10 @@
(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))))
+ (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))))
diff --git a/collects/scribble/srcdoc.rkt b/collects/scribble/srcdoc.rkt
@@ -57,18 +57,33 @@
(lambda (stx)
(syntax-case stx ()
[(_ id contract desc)
- (with-syntax ([(header result (body-stuff ...))
+ (with-syntax ([(header result (body-stuff ...) better-contract)
(syntax-case #'contract (->d -> values)
- [(->d (req ...) () (values [name res] ...))
- #'((id req ...) (values res ...) ())]
+ [(->d ([arg-id arg/c] ...) () (values [name res] ...))
+ #'((id [arg-id arg/c] ...)
+ (values res ...)
+ ()
+ (-> arg/c ... (values res ...)))]
[(->d (req ...) () #:pre-cond condition (values [name res] ...))
- #'((id req ...) (values res ...) ((bold "Pre-condition: ") (scheme condition) "\n" "\n"))]
- [(->d (req ...) () [name res])
- #'((id req ...) res ())]
+ #'((id req ...)
+ (values 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])
- #'((id req ...) res ((bold "Pre-condition: ") (scheme condition) "\n" "\n" ))]
- [(->d (req ...) () #:rest rest rest-ctc [name res])
- #'((id req ... [rest rest-ctc] (... ...)) res ())]
+ #'((id req ...)
+ 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)
(raise-syntax-error
#f
@@ -83,7 +98,7 @@
stx
#'contract)]
[(-> result)
- #'((id) result ())]
+ #'((id) result () contract)]
[(-> whatever ...)
(raise-syntax-error
#f
@@ -98,7 +113,7 @@
stx
#'contract)])])
(values
- #'[id contract]
+ #'[id better-contract]
#'(defproc header result body-stuff ... . desc)
#'(scribble/manual)
#'id))])))
diff --git a/collects/scribblings/scribble/reader.scrbl b/collects/scribblings/scribble/reader.scrbl
@@ -141,7 +141,7 @@ expressions.
}===|
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
@racket[quote]:
diff --git a/collects/scribblings/scribble/sigplan.scrbl b/collects/scribblings/scribble/sigplan.scrbl
@@ -65,9 +65,9 @@ Declares information that is collected into the copyright region of the paper.}
@defproc[(category [CR-number pre-content?]
[subcategory pre-content?]
[third-level pre-content?]
- [fourth-level (or/c #f pre-content?) #f]) block?]
-@defproc[(terms [content pre-content?] ...) block?]
-@defproc[(keywords [content pre-content?] ...) block?]
+ [fourth-level (or/c #f pre-content?) #f]) content?]
+@defproc[(terms [content pre-content?] ...) content?]
+@defproc[(keywords [content pre-content?] ...) content?]
)]{
Typesets category, term, and keyword information for the paper, which
diff --git a/collects/scriblib/autobib.rkt b/collects/scriblib/autobib.rkt
@@ -1,4 +1,4 @@
-#lang at-exp scheme/base
+#lang at-exp racket/base
(require scribble/manual
scribble/core
scribble/decode
@@ -41,6 +41,25 @@
(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)
(make-element
#f
@@ -48,7 +67,12 @@
"("
(let loop ([keys bib-entries])
(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
#f
(list (loop (list (car keys)))
@@ -87,23 +111,17 @@
`(autobib ,(auto-bib-key k))))
(lambda (ci)
(collect-put! ci
- `(autobib-cite ,(auto-bib-key k))
+ `(autobib-author ,(auto-bib-key k))
(make-element
#f
(list
- (author-element-cite (auto-bib-author k))
- " "
- (auto-bib-date k))))
+ (author-element-cite (auto-bib-author k)))))
(collect-put! ci
- `(autobib-inline ,(auto-bib-key k))
+ `(autobib-date ,(auto-bib-key k))
(make-element
#f
(list
- (author-element-cite (auto-bib-author k))
- 'nbsp
- "("
- (auto-bib-date k)
- ")")))))))))
+ (auto-bib-date k))))))))))
bibs)))
null)))
@@ -112,8 +130,8 @@
(define group (make-bib-group (make-hasheq)))
(define (~cite bib-entry . bib-entries)
(add-cites group (cons bib-entry bib-entries)))
- (define (citet bib-entry)
- (add-cite group bib-entry 'autobib-inline))
+ (define (citet bib-entry . bib-entries)
+ (add-inline-cite group (cons bib-entry bib-entries)))
(define (generate-bibliography #:tag [tag "doc-bibliography"])
(gen-bib tag group))))
@@ -171,7 +189,7 @@
(if (author-element? a)
a
(let* ([s (content->string a)]
- [m (regexp-match #px"^(.*) (\\p{L}+)$" s)])
+ [m (regexp-match #px"^(.*) (([\\-]|\\p{L})+)$" s)])
(make-author-element
#f
(list a)
diff --git a/collects/scriblib/gui-eval.rkt b/collects/scriblib/gui-eval.rkt
@@ -8,21 +8,40 @@
racket/runtime-path
racket/serialize
"private/gui-eval-exn.ss"
- racket/system)
+ racket/system
+ (for-syntax racket/base))
(define-syntax define-mr
(syntax-rules ()
[(_ mr orig)
(begin
(provide mr)
- (define-syntax mr
- (syntax-rules ()
+ (define-syntax (mr stx)
+ (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 (... ...))
- (parameterize ([scribble-eval-handler gui-eval-handler])
- (orig #:eval gui-eval x (... ...)))])))]))
+ #'(parameterize ([scribble-eval-handler (gui-eval-handler gui-eval
+ (λ () (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 mred? (getenv "MREVAL"))
+
+(when mred?
+ (gui-eval '(require racket/gui/base))
+ (gui-eval '(require slideshow)))
+
(define-mr gui-interaction interaction)
(define-mr gui-interaction-eval interaction-eval)
(define-mr gui-interaction-eval-show interaction-eval-show)
@@ -34,12 +53,6 @@
(provide (rename-out [gui-racketmod+eval gui-schememod+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
;; exprs.dat file:
(define img-dir "images") ; relative to src dir
@@ -52,16 +65,20 @@
(if mred?
(let ([eh (scribble-eval-handler)]
[log-file (open-output-file exprs-dat-file #:exists 'truncate/replace)])
- (lambda (ev catching-exns? expr)
- (write (serialize (if (syntax? expr) (syntax->datum expr) expr)) log-file)
- (newline log-file)
- (flush-output log-file)
- (let ([result
- (with-handlers ([exn:fail?
- (lambda (exn)
- (make-gui-exn (exn-message exn)))])
- (eh ev catching-exns? expr))])
- (let ([result (fixup-picts result)])
+ (λ (gui-eval get-predicate? get-render get-get-width get-get-height)
+ (lambda (ev catching-exns? expr)
+ (write (serialize (if (syntax? expr) (syntax->datum expr) expr)) log-file)
+ (newline log-file)
+ (flush-output log-file)
+ (let ([result
+ (with-handlers ([exn:fail?
+ (lambda (exn)
+ (make-gui-exn (exn-message exn)))])
+ ;; 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)
(newline log-file)
(flush-output log-file)
@@ -74,71 +91,73 @@
(lambda (exn)
(open-input-string ""))])
(open-input-file exprs-dat-file))])
- (lambda (ev catching-exns? expr)
- (with-handlers ([exn:fail? (lambda (exn)
- (if catching-exns?
- (raise exn)
- (void)))])
- (let ([v (read log-file)])
- (if (eof-object? v)
- (error "expression not in log file")
- (let ([v (deserialize v)])
- (if (equal? v (if (syntax? expr)
- (syntax->datum expr)
- expr))
- (let ([v (read log-file)])
- (if (eof-object? v)
- (error "expression result missing in log file")
- (let ([v (deserialize v)])
- (if (gui-exn? v)
- (raise (make-exn:fail
- (gui-exn-message v)
- (current-continuation-marks)))
- v))))
- (error 'mreval
- "expression does not match log file: ~e versus: ~e"
- expr
- v))))))))))
+ (λ (gui-eval get-predicate? get-render get-get-width get-get-height)
+ (lambda (ev catching-exns? expr)
+ (with-handlers ([exn:fail? (lambda (exn)
+ (if catching-exns?
+ (raise exn)
+ (void)))])
+ (let ([v (read log-file)])
+ (if (eof-object? v)
+ (error "expression not in log file")
+ (let ([v (deserialize v)])
+ (if (equal? v (if (syntax? expr)
+ (syntax->datum expr)
+ expr))
+ (let ([v (read log-file)])
+ (if (eof-object? v)
+ (error "expression result missing in log file")
+ (let ([v (deserialize v)])
+ (if (gui-exn? v)
+ (raise (make-exn:fail
+ (gui-exn-message v)
+ (current-continuation-marks)))
+ v))))
+ (error 'mreval
+ "expression does not match log file: ~e versus: ~e"
+ expr
+ v)))))))))))
(define image-counter 0)
;; This path will be marshaled for use on multiple platforms
(define (build-string-path a b) (string-append a "/" b))
-(define (fixup-picts v)
- (cond
- [((gui-eval 'pict?) v)
- (let ([fn (build-string-path img-dir
- (format "img~a.png" image-counter))])
- (set! image-counter (add1 image-counter))
- (let ([dc (let ([pss (make-object (gui-eval 'ps-setup%))])
- (send pss set-mode 'file)
- (send pss set-file (path-replace-suffix fn #".ps"))
- (parameterize ([(gui-eval 'current-ps-setup) pss])
- (make-object (gui-eval 'post-script-dc%) #f)))])
- (send dc start-doc "Image")
- (send dc start-page)
- (((gui-eval 'make-pict-drawer) v) dc 0 0)
- (send dc end-page)
- (send dc end-doc)
- (system (format "epstopdf ~a" (path-replace-suffix fn #".ps"))))
- (let* ([bm (make-object (gui-eval 'bitmap%)
- (inexact->exact (ceiling ((gui-eval 'pict-width) v)))
- (inexact->exact (ceiling ((gui-eval 'pict-height) v))))]
- [dc (make-object (gui-eval 'bitmap-dc%) bm)])
- (send dc set-smoothing 'aligned)
- (send dc clear)
- (((gui-eval 'make-pict-drawer) v) dc 0 0)
- (send bm save-file fn 'png)
- (make-image-element
- #f
- (list "[image]")
- ;; Be sure to use a string rather than a path, because
- ;; it gets recorded in "exprs.dat".
- (path->string (path-replace-suffix fn #""))
- '(".pdf" ".png")
- 1.0)))]
- [(pair? v) (cons (fixup-picts (car v))
- (fixup-picts (cdr v)))]
- [(serializable? v) v]
- [else (make-element #f (list (format "~s" v)))]))
+(define (fixup-picts predicate? render get-width get-height v)
+ (let loop ([v v])
+ (cond
+ [(predicate? v)
+ (let ([fn (build-string-path img-dir
+ (format "img~a.png" image-counter))])
+ (set! image-counter (add1 image-counter))
+ (let ([dc (let ([pss (make-object (gui-eval 'ps-setup%))])
+ (send pss set-mode 'file)
+ (send pss set-file (path-replace-suffix fn #".ps"))
+ (parameterize ([(gui-eval 'current-ps-setup) pss])
+ (make-object (gui-eval 'post-script-dc%) #f)))])
+ (send dc start-doc "Image")
+ (send dc start-page)
+ (render v dc 0 0)
+ (send dc end-page)
+ (send dc end-doc)
+ (system (format "epstopdf ~a" (path-replace-suffix fn #".ps"))))
+ (let* ([bm (make-object (gui-eval 'bitmap%)
+ (inexact->exact (ceiling (get-width v)))
+ (inexact->exact (ceiling (get-height v))))]
+ [dc (make-object (gui-eval 'bitmap-dc%) bm)])
+ (send dc set-smoothing 'aligned)
+ (send dc clear)
+ (render v dc 0 0)
+ (send bm save-file fn 'png)
+ (make-image-element
+ #f
+ (list "[image]")
+ ;; Be sure to use a string rather than a path, because
+ ;; it gets recorded in "exprs.dat".
+ (path->string (path-replace-suffix fn #""))
+ '(".pdf" ".png")
+ 1.0)))]
+ [(pair? v) (cons (loop (car v))
+ (loop (cdr v)))]
+ [(serializable? v) v]
+ [else (make-element #f (list (format "~s" v)))])))
diff --git a/collects/scriblib/scribblings/autobib.scrbl b/collects/scriblib/scribblings/autobib.scrbl
@@ -22,16 +22,21 @@ Binds @scheme[~cite-id], @scheme[citet-id], and
@scheme[generate-bibliography-id], which share state to accumulate and
render citations.
-The function bound to @scheme[~cite-id] produces a citation with a
-preceding non-breaking space. It has the contract
+The function bound to @scheme[~cite-id] produces a citation referring
+to one or more bibliography entries with a preceding non-breaking
+space. It has the contract
@schemeblock[
((bib?) () (listof bib?) . ->* . element?)
]
-The function bound to @scheme[citet-id] has the same contract as the
-function for @scheme[~cite-id], but it generates an element suitable
-for use as a noun refering to the document or its author.
+The function bound to @scheme[citet-id] generates an element suitable
+for use as a noun---referring to a document or its author---for one
+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
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
first, last names, and name suffixes separately, so that names can be
ordered and rendered correctly. When a string is provided as an author
-name, the last non-empty sequence of ASCII alphabetic characters after
-a space is treated as the author name, and the rest is treated as the
-first name.}
+name, the last non-empty sequence of alphabetic characters or
+@litchar["-"] after a space is treated as the author name, and the
+rest is treated as the first name.}
@defproc[(in-bib [orig bib?] [where string?]) bib?]{
diff --git a/collects/scriblib/scribblings/gui-eval.scrbl b/collects/scriblib/scribblings/gui-eval.scrbl
@@ -16,16 +16,65 @@ images. Future runs (with the environment variable unset) use the
generated image.
@deftogether[(
-@defform[(gui-interaction datum ...)]
-@defform[(gui-interaction-eval datum ...)]
-@defform[(gui-interaction-eval-show datum ...)]
-@defform[(gui-schemeblock+eval datum ...)]
-@defform[(gui-schememod+eval datum ...)]
-@defform[(gui-def+int datum ...)]
-@defform[(gui-defs+int datum ...)]
+@defform*[((gui-interaction datum ...)
+ (gui-interaction
+ #:eval+opts the-eval get-predicate? get-render
+ get-get-width get-get-height
+ 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
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).}
+ ]
+
+}
