diff --git a/collects/help/search.rkt b/collects/help/search.rkt index 4cfb6dd4..27eaf8fe 100644 --- 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 index ffe89407..1f8fa1a6 100644 --- 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 index 3655fc3d..774a299c 100644 --- 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 index 721a4e22..d5e0a03a 100644 --- 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 index ee64f3c9..6cb4a99c 100644 --- 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 index 6e74a799..298659eb 100644 --- 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 index 2e5b70b1..d00e1b1e 100644 --- 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 index 349a73ce..80d7311d 100644 --- 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 index 98f74075..6784fe8e 100644 --- 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/scheme.css b/collects/scribble/racket.css similarity index 82% rename from collects/scribble/scheme.css rename to collects/scribble/racket.css index 21b42dbd..0644698e 100644 --- a/collects/scribble/scheme.css +++ b/collects/scribble/racket.css @@ -2,9 +2,9 @@ /* See the beginning of "scribble.css". */ /* Monospace: */ -.ScmIn, .ScmRdr, .ScmPn, .ScmMeta, -.ScmMod, .ScmKw, .ScmVar, .ScmSym, -.ScmRes, .ScmOut, .ScmCmt, .ScmVal { +.RktIn, .RktRdr, .RktPn, .RktMeta, +.RktMod, .RktKw, .RktVar, .RktSym, +.RktRes, .RktOut, .RktCmt, .RktVal { font-family: monospace; } @@ -35,84 +35,84 @@ } /* ---------------------------------------- */ -/* Scheme text styles */ +/* Racket text styles */ -.ScmIn { +.RktIn { color: #cc6633; background-color: #eeeeee; } -.ScmInBG { +.RktInBG { background-color: #eeeeee; } -.ScmRdr { +.RktRdr { } -.ScmPn { +.RktPn { color: #843c24; } -.ScmMeta { +.RktMeta { color: black; } -.ScmMod { +.RktMod { color: black; } -.ScmOpt { +.RktOpt { color: black; } -.ScmKw { +.RktKw { color: black; font-weight: bold; } -.ScmErr { +.RktErr { color: red; font-style: italic; } -.ScmVar { +.RktVar { color: #262680; font-style: italic; } -.ScmSym { +.RktSym { color: #262680; } -.ScmValLink { +.RktValLink { text-decoration: none; color: blue; } -.ScmModLink { +.RktModLink { text-decoration: none; color: blue; } -.ScmStxLink { +.RktStxLink { text-decoration: none; color: black; font-weight: bold; } -.ScmRes { +.RktRes { color: #0000af; } -.ScmOut { +.RktOut { color: #960096; } -.ScmCmt { +.RktCmt { color: #c2741f; } -.ScmVal { +.RktVal { color: #228b22; } @@ -130,7 +130,7 @@ vertical-align: bottom; } -.ScmBlk td { +.RktBlk td { vertical-align: baseline; } @@ -151,7 +151,7 @@ float: right; } -.SBibliography td { +.RBibliography td { vertical-align: text-top; } @@ -165,17 +165,17 @@ margin-right: 1em; } -.Sfilebox { +.Rfilebox { margin-left: 1em; margin-right: 1em; } -.Sfiletitle { +.Rfiletitle { text-align: right; margin: 0em 0em 0em 0em; } -.Sfilename { +.Rfilename { border-top: 1px solid #6C8585; border-right: 1px solid #6C8585; padding-left: 0.5em; @@ -183,6 +183,6 @@ background-color: #ECF5F5; } -.Sfilecontent { +.Rfilecontent { margin: 0em 0em 0em 0em; } diff --git a/collects/scribble/racket.rkt b/collects/scribble/racket.rkt index 08d417f7..9c2be06c 100644 --- 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 new file mode 100644 index 00000000..817f6bc8 --- /dev/null +++ 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/sigplan.rkt b/collects/scribble/sigplan.rkt index 4da3af5f..41fcf979 100644 --- 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 index 454e85d5..65823598 100644 --- 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 index da1901ce..ca02c0d9 100644 --- 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 index 49f2a450..90eaf36b 100644 --- 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 index 367449b1..7083853d 100644 --- 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 index 49d988c4..e6e93f93 100644 --- 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 index acf86c4e..66a7c57c 100644 --- 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 index f6a86f80..48682f11 100644 --- 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).} + ] + +}