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

scribble HTML output: add page-specific table-of-contents; also add call-with-values and values to reference

Browse Source 
svn: r7025
This commit is contained in:
Matthew Flatt 2007-08-05 15:49:45 +00:00
parent 972429ddf7
commit 36c962cae1
9 changed files with 597 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -273,24 +273,32 @@
;; ----------------------------------------
(define/public (table-of-contents part ht)
(define/private (do-table-of-contents part ht delta quiet)
(make-table #f (render-toc part
(sub1 (length (collected-info-number
(+ delta
(length (collected-info-number
(part-collected-info part))))
#t)))
#t
quiet)))
(define/public (table-of-contents part ht)
(do-table-of-contents part ht -1 not))
(define/public (local-table-of-contents part ht)
(table-of-contents part ht))
(define/private (render-toc part base-len skip?)
(define/public (quiet-table-of-contents part ht)
(do-table-of-contents part ht 1 (lambda (x) #t)))
(define/private (render-toc part base-len skip? quiet)
(let ([number (collected-info-number (part-collected-info part))])
(let ([subs
(if (not (and (styled-part? part)
(if (quiet (and (styled-part? part)
(eq? 'quiet (styled-part-style part))
(not (= base-len (sub1 (length number))))))
(apply
append
(map (lambda (p) (render-toc p base-len #f)) (part-parts part)))
(map (lambda (p) (render-toc p base-len #f quiet)) (part-parts part)))
null)])
(if skip?
subs

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

@ -32,7 +32,8 @@
get-dest-directory
format-number
strip-aux
lookup)
lookup
quiet-table-of-contents)
(define/override (get-suffix) #".html")
@ -47,7 +48,11 @@
fns)
ht))
(define/public (part-whole-page? d)
(define/public (part-whole-page? p ht)
(let ([dest (lookup p ht `(part ,(part-tag p)))])
(caddr dest)))
(define/public (current-part-whole-page?)
#f)
(define/override (collect-part-tag d ht number)
@ -55,7 +60,7 @@
`(part ,(part-tag d))
(list (current-output-file)
(part-title-content d)
(part-whole-page? d))))
(current-part-whole-page?))))
(define/override (collect-target-element i ht)
(hash-table-put! ht
@ -71,7 +76,8 @@
(if p
(loop p d)
(values d mine))))])
`((div ((class "tocview"))
`((div ((class "tocset"))
(div ((class "tocview"))
(div ((class "tocviewtitle"))
(a ((href "index.html")
(class "tocviewlink"))
@ -101,7 +107,86 @@
"tocviewselflink"
"tocviewlink")))
,@(render-content (part-title-content p) d ht)))))
(part-parts top)))))))
(part-parts top))))
,@(if (ormap (lambda (p) (part-whole-page? p ht)) (part-parts d))
null
(let ([ps (cdr
(let flatten ([d d])
(cons d
(apply
append
(letrec ([flow-targets
(lambda (flow)
(apply append (map flow-element-targets (flow-paragraphs flow))))]
[flow-element-targets
(lambda (e)
(cond
[(table? e) (table-targets e)]
[(paragraph? e) (para-targets e)]
[(itemization? e)
(apply append (map flow-targets (itemization-flows e)))]
[(blockquote? e)
(apply append (map flow-element-targets (blockquote-paragraphs e)))]
[(delayed-flow-element? e)
null]))]
[para-targets
(lambda (para)
(let loop ([c (paragraph-content para)])
(cond
[(empty? c) null]
[else (let ([a (car c)])
(cond
[(toc-target-element? a)
(cons a (loop (cdr c)))]
[(element? a)
(append (loop (element-content a))
(loop (cdr c)))]
[(delayed-element? a)
(loop (cons (force-delayed-element a this d ht)
(cdr c)))]
[else
(loop (cdr c))]))])))]
[table-targets
(lambda (table)
(apply append
(map (lambda (flows)
(apply append (map (lambda (f)
(if (eq? f 'cont)
null
(flow-targets f)))
flows)))
(table-flowss table))))])
(apply append (map flow-element-targets (flow-paragraphs (part-flow d)))))
(map flatten (part-parts d))))))])
(if (null? ps)
null
`((div ((class "tocsub"))
(div ((class "tocsubtitle"))
"On this page:")
(table
((class "tocsublist")
(cellspacing "0"))
,@(map (lambda (p)
(parameterize ([current-no-links #t])
`(tr
(td
,@(if (part? p)
`((span ((class "tocsublinknumber"))
,@(format-number (collected-info-number (part-collected-info p))
'((tt nbsp)))))
'(""))
(a ((href ,(if (part? p)
(let ([dest (lookup p ht `(part ,(part-tag p)))])
(format "#~a"
`(part ,(part-tag p))))
(format "#~a" (target-element-tag p))))
(class ,(if (part? p)
"tocsubseclink"
"tocsublink")))
,@(if (part? p)
(render-content (part-title-content p) d ht)
(render-content (element-content p) d ht)))))))
ps)))))))))))
(define/public (render-one-part d ht fn number)
(parameterize ([current-output-file fn])
@ -356,7 +441,7 @@
(build-path fn "index.html"))
fns)))
(define/override (part-whole-page? d)
(define/override (current-part-whole-page?)
((collecting-sub) . <= . 2))
(define/private (toc-part? d)

23
collects/scribble/manual.ss
View File

@ -487,7 +487,7 @@
(loop (cdr a) (cons (car a) o-accum)))))
(loop (cdr a) (cons (car a) r-accum))))]
[(tagged) (if first?
(make-target-element
(make-toc-target-element
#f
(list (to-element (make-just-context (car prototype)
stx-id)))
@ -661,12 +661,13 @@
(cons #t (map (lambda (x) #f) (cdr prototypes))))))
(content-thunk))))))
(define (make-target-element* stx-id content wrappers)
(define (make-target-element* inner-make-target-element stx-id content wrappers)
(if (null? wrappers)
content
(make-target-element*
make-target-element
stx-id
(make-target-element
(inner-make-target-element
#f
(list content)
(register-scheme-definition
@ -687,12 +688,12 @@
(list (make-flow
(list
(let* ([the-name
(let ([just-name
(make-target-element*
make-toc-target-element
stx-id
(to-element (if (pair? name)
(map (lambda (x)
(make-just-context x stx-id))
name)
(make-just-context (car name) stx-id)
stx-id))
(let ([name (if (pair? name)
(car name)
@ -708,7 +709,11 @@
null
(map (lambda (f)
(list 'set- name '- (car f) '!))
fields))))))]
fields))))))])
(if (pair? name)
(to-element (list just-name
(make-just-context (cadr name) stx-id)))
just-name))]
[short-width (apply +
(length fields)
8
@ -836,7 +841,7 @@
(list (make-flow
(list
(make-paragraph
(list (make-target-element
(list (make-toc-target-element
#f
(list (to-element (make-just-context name stx-id)))
(register-scheme-definition stx-id))
@ -885,7 +890,7 @@
. ,(cdr form)))))))
(and kw-id
(eq? form (car forms))
(make-target-element
(make-toc-target-element
#f
(list (to-element (make-just-context (if (pair? form)
(car form)

40
collects/scribble/scribble.css
View File

@ -35,15 +35,24 @@
border: 0.5em solid #F5F5DC;
}
.tocview {
.tocset {
position: relative;
float: left;
width: 10em;
margin-right: 2em;
}
.tocview {
text-align: left;
background-color: #F5F5DC;
}
.tocsub {
margin-top: 1em;
text-align: left;
background-color: #DCF5F5;
}
.tocviewtitle {
font-size: 80%;
font-weight: bold;
@ -63,6 +72,35 @@
text-decoration: none;
}
.tocsublist {
margin: 0.2em 0.2em 0.2em 0.2em;
}
.tocsublist td {
vertical-align: top;
padding-left: 1em;
text-indent: -1em;
}
.tocsublinknumber {
font-size: 80%;
}
.tocsublink {
text-decoration: none;
}
.tocsubseclink {
font-size: 80%;
text-decoration: none;
}
.tocsubtitle {
font-size: 80%;
font-style: italic;
margin: 0.2em 0.2em 0.2em 0.2em;
}
.leftindent {
margin-left: 1em;
margin-right: 0em;

1
collects/scribble/struct.ss
View File

@ -72,6 +72,7 @@
[element ([style any/c]
[content list?])]
[(target-element element) ([tag tag?])]
[(toc-target-element target-element) ()]
[(link-element element) ([tag tag?])]
[(index-element element) ([tag tag?]
[plain-seq (listof string?)]

341
collects/scribblings/reference/contracts.scrbl
View File

@ -802,3 +802,344 @@ source location of the location where the contract was assumed. If the
syntax object wraps a symbol, the symbol is used as the name of the
primitive whose contract was assumed. If absent, it defaults to the
source location of the @scheme[contract] expression.}
@; ------------------------------------------------------------------------
@section{Building New Contract Combinators}
Contracts are represented internally as functions that
accept information about the contract (who is to blame,
source locations, etc) and produce projections (in the
spirit of Dana Scott) that enforce the contract. A
projection is a function that accepts an arbitrary value,
and returns a value that satisfies the corresponding
contract. For example, a projection that accepts only
integers corresponds to the contract @scheme[(flat-contract
integer?)], and can be written like this:
@schemeblock[
(define int-proj
(lambda (x)
(if (integer? x)
x
(signal-contract-violation))))
]
As a second example, a projection that accepts unary functions
on integers looks like this:
@schemeblock[
(define int->int-proj
(lambda (f)
(if (and (procedure? f)
(procedure-arity-includes? f 1))
(lambda (x)
(int-proj (f (int-proj x))))
(signal-contract-violation))))
]
Although these projections have the right error behavior,
they are not quite ready for use as contracts, because they
do not accomodate blame, and do not provide good error
messages. In order to accomodate these, contracts do not
just use simple projections, but use functions that accept
the names of two parties that are the candidates for blame,
as well as a record of the source location where the
contract was established and the name of the contract. They
can then, in turn, pass that information
to @scheme[raise-contract-error] to signal a good error
message (see below for details on its behavior).
Here is the first of those two projections, rewritten for
use in the contract system:
@schemeblock[
(define (int-proj pos neg src-info contract-name)
(lambda (x)
(if (integer? x)
x
(raise-contract-error
val
src-info
pos
contract-name
"expected <integer>, given: ~e"
val))))
]
The first two new arguments specify who is to be blamed for
positive and negative contract violations,
respectively. Contracts, in this system, are always
established between two parties. One party provides some
value according to the contract, and the other consumes the
value, also according to the contract. The first is called
the ``positive'' person and the second the ``negative''. So,
in the case of just the integer contract, the only thing
that can go wrong is that the value provided is not an
integer. Thus, only the positive argument can ever accrue
blame (and thus only @scheme[pos] is passed
to @scheme[raise-contract-error]).
Compare that to the projection for our function contract:
@schemeblock[
(define (int->int-proj pos neg src-info contract-name)
(let ([dom (int-proj neg pos src-info contract-name)]
[rng (int-proj pos neg src-info contract-name)])
(lambda (f)
(if (and (procedure? f)
(procedure-arity-includes? f 1))
(lambda (x)
(rng (f (dom x))))
(raise-contract-error
val
src-info
pos
contract-name
"expected a procedure of one argument, given: ~e"
val)))))
]
In this case, the only explicit blame covers the situation
where either a non-procedure is supplied to the contract, or
where the procedure does not accept one argument. As with
the integer projection, the blame here also lies with the
producer of the value, which is
why @scheme[raise-contract-error] gets @scheme[pos] and
not @scheme[neg] as its argument.
The checking for the domain and range are delegated to
the @scheme[int-proj] function, which is supplied its
arguments in the first two line of
the @scheme[int->int-proj] function. The trick here is that,
even though the @scheme[int->int-proj] function always
blames what it sees as positive we can reverse the order of
the @scheme[pos] and @scheme[neg] arguments so that the
positive becomes the negative.
This is not just a cheap trick to get this example to work,
however. The reversal of the positive and the negative is a
natural consequence of the way functions behave. That is,
imagine the flow of values in a program between two
modules. First, one module defines a function, and then that
module is required by another. So, far the function itself
has to go from the original, providing module to the
requiring module. Now, imagine that the providing module
invokes the function, suppying it an argument. At this
point, the flow of values reverses. The argument is
travelling back from the requiring module to the providing
module! And finally, when the function produces a result,
that result flows back in the original
direction. Accordingly, the contract on the domain reverses
the positive and the negative, just like the flow of values
reverses.
We can use this insight to generalize the function contracts
and build a function that accepts any two contracts and
returns a contract for functions between them.
@schemeblock[
(define (make-simple-function-contract dom-proj range-proj)
(lambda (pos neg src-info contract-name)
(let ([dom (dom-proj neg pos src-info contract-name)]
[rng (range-proj pos neg src-info contract-name)])
(lambda (f)
(if (and (procedure? f)
(procedure-arity-includes? f 1))
(lambda (x)
(rng (f (dom x))))
(raise-contract-error
val
src-info
pos
contract-name
"expected a procedure of one argument, given: ~e"
val))))))
]
Projections like the ones described above, but suited to
other, new kinds of value you might make, can be used with
the contract library primitives below.
@defproc[(make-proj-contract [name any/c]
[proj (symbol? symbol? any/c any/c . -> . any/c)]
[first-order-test (any/c . -> . any/c)])
contract?]{
The simplest way to build a contract. It can be less
efficient than using other contract constructors described
below, but it is the right choice for new contract
constructors or first-time contract builders.
The first argument is the name of the contract. It can be an
arbitrary s-expression. The second is a projection (see
above).
The final argument is a predicate that is a
conservative, first-order test of a value. It should be a
function that accepts one argument and returns a boolean. If
it returns @scheme[#f], its argument must be guaranteed to
fail the contract, and the contract should detect this right
when the projection is invoked. If it returns true,
the value may or may not violate the contract, but any
violations must not be signaled immediately.
From the example above, the predicate should accept unary
functions, but reject all other values.}
@defproc[(build-compound-type-name [c/s any/c] ...) any]{
Produces an s-expression to be used as a name
for a contract. The arguments should be either contracts or
symbols. It wraps parenthesis around its arguments and
extracts the names from any contracts it is supplied with.}
@defform[(coerce-contract id expr)]{
Evaluates @scheme[expr] and, if the result is a
contract, just returns it. If the result is a procedure of arity
one, it converts that into a contract. If the result is neither, it
signals an error, using the first argument in the error
message. The message says that a contract or a procedure of
arity one was expected.}
@defproc[(flat-contract/predicate? [val any/c]) boolean?]{
A predicate that indicates when @scheme[coerce-contract] will fail.}
@defproc[(raise-contract-error [val any/c]
[src-info any/c]
[to-blame symbol?]
[contract-name any/c]
[fmt string?]
[arg any/c] ...)
any]{
Signals a contract violation. The first argument is the value that
failed to satisfy the contract. The second argument is is the
@scheme[src-info] passed to the projection and the third should be
either @scheme[pos] or @scheme[neg] (typically @scheme[pos], see the
beginning of this section) that was passed to the projection. The
fourth argument is the @scheme[contract-name] that was passed to the
projection and the remaining arguments are used with @scheme[format]
to build an actual error message.}
@;{
% to document:
% proj-prop proj-pred? proj-get
% name-prop name-pred? name-get
% stronger-prop stronger-pred? stronger-get
% flat-prop flat-pred? flat-get
% first-order-prop first-order-get
% contract-stronger?
}
@; ------------------------------------------------------------------------
@section{Contract Utilities}
@defproc[(guilty-party [exn exn?]) any]{
Extracts the name of the guilty party from an exception
raised by the contract system.}
@defproc[(contract? [v any/c]) boolean?]{
Returns @scheme[#t] if its argument is a contract (ie, constructed
with one of the combinators described in this section), @scheme[#f]
otherwise.}
@defproc[(flat-contract? [v any/c]) boolean?]{
Returns @scheme[#t] when its argument is a contract that has been
constructed with @scheme[flat-contract] (and thus is essentially just
a predicate), @scheme[#f] otherwise.}
@defproc[(flat-contract-predicate [v flat-contract?])
(any/c . -> . any/c)]{
Extracts the predicate from a flat contract.}
@defproc[(contract-first-order-passes? [contract contract?]
[v any/c])
boolean?]{
Returns a boolean indicating if the first-order tests
of @scheme[contract] pass for @scheme[v].
If it returns @scheme[#f], the contract is guaranteed not to
hold for that value; if it returns @scheme[#t], the contract
may or may not hold. If the contract is a first-order
contract, a result of @scheme[#t] guarantees that the
contract holds.}
@defproc[(make-none/c [sexp-name any/c]) contract?]{
Makes a contract that accepts no values, and reports the
name @scheme[sexp-name] when signaling a contract violation.}
@defparam[contract-violation->string
proc
(any/c any/c symbol? symbol? any/c string? . -> . string?)]{
This is a parameter that is used when constructing a
contract violation error. Its value is procedure that
accepts six arguments: the value that the contract applies
to, a syntax object representing the source location where
the contract was established, the names of the two parties
to the contract (as symbols) where the first one is the
guilty one, an sexpression representing the contract, and a
message indicating the kind of violation. The procedure then
returns a string that is put into the contract error
message. Note that the value is often already included in
the message that indicates the violation.}
@defform[(recursive-contract contract-expr)]{
Delays the evaluation of its argument until the contract is checked,
making recursive contracts possible.}
@defform[(opt/c contract-expr)]{
This optimizes its argument contract expression by
traversing its syntax and, for known contract combinators,
fuses them into a single contract combinator that avoids as
much allocation overhad as possible. The result is a
contract that should behave identically to its argument,
except faster (due to the less allocation).}
@defform[(define-opt/c (id id ...) expr)]{
This defines a recursive contract and simultaneously
optimizes it. Semantically, it behaves just as if
the @scheme[-opt/c] were not present, defining a function on
contracts (except that the body expression must return a
contract). But, it also optimizes that contract definition,
avoiding extra allocation, much like @scheme[opt/c] does.
For example,
@schemeblock[
(define-contract-struct bt (val left right))
(define-opt/c (bst-between/c lo hi)
(or/c null?
(bt/c [val (between/c lo hi)]
[left (val) (bst-between/c lo val)]
[right (val) (bst-between/c val hi)])))
(define bst/c (bst-between/c -inf.0 +inf.0))
]
defines the @scheme[bst/c] contract that checks the binary
search tree invariant. Removing the @scheme[-opt/c] also
makes a binary search tree contract, but one that is
(approximately) 20 times slower.}

1
collects/scribblings/reference/control.scrbl
View File

@ -5,6 +5,7 @@
@local-table-of-contents[]
@include-section["values.scrbl"]
@include-section["exns.scrbl"]
@include-section["cont.scrbl"]
@include-section["cont-marks.scrbl"]

2
collects/scribblings/reference/model.scrbl
View File

@ -119,7 +119,7 @@ specification of @tech{tail positions} goes with each syntactic form,
like @scheme[if].
@;------------------------------------------------------------------------
@section{Multiple Return Values}
@section[#:tag "mz:values-model"]{Multiple Return Values}
A Scheme expression can evaluate to @deftech{multiple values}, in the
same way that a procedure can accept multiple arguments.

35
collects/scribblings/reference/values.scrbl Normal file
View File

@ -0,0 +1,35 @@
#reader(lib "docreader.ss" "scribble")
@require["mz.ss"]
@title[#:tag "mz:values"]{Multiple Values}
See @secref["mz:values-model"] for general information about multiple
result values. In addition to @scheme[call-with-values] (described in
this section), the @scheme[let-values], @scheme[let*-values],
@scheme[letrec-values], and @scheme[define-values] forms (among
others) create continuations that receive multiple values.
@defproc[(values [v any/c] ...) any]{
Returns the given @scheme[v]s. That is, @scheme[values] returns as
provided arguments.
@examples[
(values 1)
(values 1 2 3)
(values)
]}
@defproc[(call-with-values [generator (-> any)] [receiver procedure?]) any]{
Calls @scheme[generator], and passes the values that
@scheme[generator] produces as arguments to @scheme[receiver]. Thus,
@scheme[call-with-values] creates a continuation that accepts any
number of values that @scheme[receiver] can accept. The
@scheme[receiver] procedure is called in tail position with respect to
the @scheme[call-with-values] call.
@examples[
(call-with-values (lambda () (values 1 2)) +)
(call-with-values (lambda () 1) (lambda (x y) (+ x y)))
]}