scribble HTML output: add page-specific table-of-contents; also add call-with-values and values to reference
svn: r7025
This commit is contained in:
parent
972429ddf7
commit
36c962cae1
|
@ -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
|
(make-table #f (render-toc part
|
||||||
(sub1 (length (collected-info-number
|
(+ delta
|
||||||
(part-collected-info part))))
|
(length (collected-info-number
|
||||||
#t)))
|
(part-collected-info part))))
|
||||||
|
#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)
|
(define/public (local-table-of-contents part ht)
|
||||||
(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 ([number (collected-info-number (part-collected-info part))])
|
||||||
(let ([subs
|
(let ([subs
|
||||||
(if (not (and (styled-part? part)
|
(if (quiet (and (styled-part? part)
|
||||||
(eq? 'quiet (styled-part-style part))
|
(eq? 'quiet (styled-part-style part))
|
||||||
(not (= base-len (sub1 (length number))))))
|
(not (= base-len (sub1 (length number))))))
|
||||||
(apply
|
(apply
|
||||||
append
|
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)])
|
null)])
|
||||||
(if skip?
|
(if skip?
|
||||||
subs
|
subs
|
||||||
|
|
|
@ -32,7 +32,8 @@
|
||||||
get-dest-directory
|
get-dest-directory
|
||||||
format-number
|
format-number
|
||||||
strip-aux
|
strip-aux
|
||||||
lookup)
|
lookup
|
||||||
|
quiet-table-of-contents)
|
||||||
|
|
||||||
(define/override (get-suffix) #".html")
|
(define/override (get-suffix) #".html")
|
||||||
|
|
||||||
|
@ -47,7 +48,11 @@
|
||||||
fns)
|
fns)
|
||||||
ht))
|
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)
|
#f)
|
||||||
|
|
||||||
(define/override (collect-part-tag d ht number)
|
(define/override (collect-part-tag d ht number)
|
||||||
|
@ -55,7 +60,7 @@
|
||||||
`(part ,(part-tag d))
|
`(part ,(part-tag d))
|
||||||
(list (current-output-file)
|
(list (current-output-file)
|
||||||
(part-title-content d)
|
(part-title-content d)
|
||||||
(part-whole-page? d))))
|
(current-part-whole-page?))))
|
||||||
|
|
||||||
(define/override (collect-target-element i ht)
|
(define/override (collect-target-element i ht)
|
||||||
(hash-table-put! ht
|
(hash-table-put! ht
|
||||||
|
@ -71,37 +76,117 @@
|
||||||
(if p
|
(if p
|
||||||
(loop p d)
|
(loop p d)
|
||||||
(values d mine))))])
|
(values d mine))))])
|
||||||
`((div ((class "tocview"))
|
`((div ((class "tocset"))
|
||||||
(div ((class "tocviewtitle"))
|
(div ((class "tocview"))
|
||||||
(a ((href "index.html")
|
(div ((class "tocviewtitle"))
|
||||||
(class "tocviewlink"))
|
(a ((href "index.html")
|
||||||
,@(render-content (part-title-content top) d ht)))
|
(class "tocviewlink"))
|
||||||
(div nbsp)
|
,@(render-content (part-title-content top) d ht)))
|
||||||
(table
|
(div nbsp)
|
||||||
((class "tocviewlist")
|
(table
|
||||||
(cellspacing "0"))
|
((class "tocviewlist")
|
||||||
,@(map (lambda (p)
|
(cellspacing "0"))
|
||||||
`(tr
|
,@(map (lambda (p)
|
||||||
(td
|
`(tr
|
||||||
((align "right"))
|
(td
|
||||||
,@(format-number (collected-info-number (part-collected-info p))
|
((align "right"))
|
||||||
'((tt nbsp))))
|
,@(format-number (collected-info-number (part-collected-info p))
|
||||||
(td
|
'((tt nbsp))))
|
||||||
(a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))])
|
(td
|
||||||
(format "~a~a~a"
|
(a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))])
|
||||||
(from-root (car dest)
|
(format "~a~a~a"
|
||||||
(get-dest-directory))
|
(from-root (car dest)
|
||||||
(if (caddr dest)
|
(get-dest-directory))
|
||||||
""
|
(if (caddr dest)
|
||||||
"#")
|
""
|
||||||
(if (caddr dest)
|
"#")
|
||||||
""
|
(if (caddr dest)
|
||||||
`(part ,(part-tag p))))))
|
""
|
||||||
(class ,(if (eq? p mine)
|
`(part ,(part-tag p))))))
|
||||||
"tocviewselflink"
|
(class ,(if (eq? p mine)
|
||||||
"tocviewlink")))
|
"tocviewselflink"
|
||||||
,@(render-content (part-title-content p) d ht)))))
|
"tocviewlink")))
|
||||||
(part-parts top)))))))
|
,@(render-content (part-title-content p) d ht)))))
|
||||||
|
(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)
|
(define/public (render-one-part d ht fn number)
|
||||||
(parameterize ([current-output-file fn])
|
(parameterize ([current-output-file fn])
|
||||||
|
@ -356,7 +441,7 @@
|
||||||
(build-path fn "index.html"))
|
(build-path fn "index.html"))
|
||||||
fns)))
|
fns)))
|
||||||
|
|
||||||
(define/override (part-whole-page? d)
|
(define/override (current-part-whole-page?)
|
||||||
((collecting-sub) . <= . 2))
|
((collecting-sub) . <= . 2))
|
||||||
|
|
||||||
(define/private (toc-part? d)
|
(define/private (toc-part? d)
|
||||||
|
|
|
@ -487,7 +487,7 @@
|
||||||
(loop (cdr a) (cons (car a) o-accum)))))
|
(loop (cdr a) (cons (car a) o-accum)))))
|
||||||
(loop (cdr a) (cons (car a) r-accum))))]
|
(loop (cdr a) (cons (car a) r-accum))))]
|
||||||
[(tagged) (if first?
|
[(tagged) (if first?
|
||||||
(make-target-element
|
(make-toc-target-element
|
||||||
#f
|
#f
|
||||||
(list (to-element (make-just-context (car prototype)
|
(list (to-element (make-just-context (car prototype)
|
||||||
stx-id)))
|
stx-id)))
|
||||||
|
@ -661,12 +661,13 @@
|
||||||
(cons #t (map (lambda (x) #f) (cdr prototypes))))))
|
(cons #t (map (lambda (x) #f) (cdr prototypes))))))
|
||||||
(content-thunk))))))
|
(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)
|
(if (null? wrappers)
|
||||||
content
|
content
|
||||||
(make-target-element*
|
(make-target-element*
|
||||||
|
make-target-element
|
||||||
stx-id
|
stx-id
|
||||||
(make-target-element
|
(inner-make-target-element
|
||||||
#f
|
#f
|
||||||
(list content)
|
(list content)
|
||||||
(register-scheme-definition
|
(register-scheme-definition
|
||||||
|
@ -686,38 +687,42 @@
|
||||||
(cons
|
(cons
|
||||||
(list (make-flow
|
(list (make-flow
|
||||||
(list
|
(list
|
||||||
(let* ([the-name
|
(let* ([the-name
|
||||||
(make-target-element*
|
(let ([just-name
|
||||||
stx-id
|
(make-target-element*
|
||||||
(to-element (if (pair? name)
|
make-toc-target-element
|
||||||
(map (lambda (x)
|
stx-id
|
||||||
(make-just-context x stx-id))
|
(to-element (if (pair? name)
|
||||||
name)
|
(make-just-context (car name) stx-id)
|
||||||
stx-id))
|
stx-id))
|
||||||
(let ([name (if (pair? name)
|
(let ([name (if (pair? name)
|
||||||
(car name)
|
(car name)
|
||||||
name)])
|
name)])
|
||||||
(list* (list name)
|
(list* (list name)
|
||||||
(list name '?)
|
(list name '?)
|
||||||
(list 'make- name)
|
(list 'make- name)
|
||||||
(append
|
(append
|
||||||
(map (lambda (f)
|
(map (lambda (f)
|
||||||
(list name '- (car f)))
|
(list name '- (car f)))
|
||||||
fields)
|
fields)
|
||||||
(if immutable?
|
(if immutable?
|
||||||
null
|
null
|
||||||
(map (lambda (f)
|
(map (lambda (f)
|
||||||
(list 'set- name '- (car f) '!))
|
(list 'set- name '- (car f) '!))
|
||||||
fields))))))]
|
fields))))))])
|
||||||
[short-width (apply +
|
(if (pair? name)
|
||||||
(length fields)
|
(to-element (list just-name
|
||||||
8
|
(make-just-context (cadr name) stx-id)))
|
||||||
(map (lambda (s)
|
just-name))]
|
||||||
(string-length (symbol->string s)))
|
[short-width (apply +
|
||||||
(append (if (pair? name)
|
(length fields)
|
||||||
name
|
8
|
||||||
(list name))
|
(map (lambda (s)
|
||||||
(map car fields))))])
|
(string-length (symbol->string s)))
|
||||||
|
(append (if (pair? name)
|
||||||
|
name
|
||||||
|
(list name))
|
||||||
|
(map car fields))))])
|
||||||
(if (and (short-width . < . max-proto-width)
|
(if (and (short-width . < . max-proto-width)
|
||||||
(not immutable?)
|
(not immutable?)
|
||||||
(not transparent?))
|
(not transparent?))
|
||||||
|
@ -836,7 +841,7 @@
|
||||||
(list (make-flow
|
(list (make-flow
|
||||||
(list
|
(list
|
||||||
(make-paragraph
|
(make-paragraph
|
||||||
(list (make-target-element
|
(list (make-toc-target-element
|
||||||
#f
|
#f
|
||||||
(list (to-element (make-just-context name stx-id)))
|
(list (to-element (make-just-context name stx-id)))
|
||||||
(register-scheme-definition stx-id))
|
(register-scheme-definition stx-id))
|
||||||
|
@ -885,7 +890,7 @@
|
||||||
. ,(cdr form)))))))
|
. ,(cdr form)))))))
|
||||||
(and kw-id
|
(and kw-id
|
||||||
(eq? form (car forms))
|
(eq? form (car forms))
|
||||||
(make-target-element
|
(make-toc-target-element
|
||||||
#f
|
#f
|
||||||
(list (to-element (make-just-context (if (pair? form)
|
(list (to-element (make-just-context (if (pair? form)
|
||||||
(car form)
|
(car form)
|
||||||
|
|
|
@ -35,15 +35,24 @@
|
||||||
border: 0.5em solid #F5F5DC;
|
border: 0.5em solid #F5F5DC;
|
||||||
}
|
}
|
||||||
|
|
||||||
.tocview {
|
.tocset {
|
||||||
position: relative;
|
position: relative;
|
||||||
float: left;
|
float: left;
|
||||||
width: 10em;
|
width: 10em;
|
||||||
margin-right: 2em;
|
margin-right: 2em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocview {
|
||||||
text-align: left;
|
text-align: left;
|
||||||
background-color: #F5F5DC;
|
background-color: #F5F5DC;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
.tocsub {
|
||||||
|
margin-top: 1em;
|
||||||
|
text-align: left;
|
||||||
|
background-color: #DCF5F5;
|
||||||
|
}
|
||||||
|
|
||||||
.tocviewtitle {
|
.tocviewtitle {
|
||||||
font-size: 80%;
|
font-size: 80%;
|
||||||
font-weight: bold;
|
font-weight: bold;
|
||||||
|
@ -63,6 +72,35 @@
|
||||||
text-decoration: none;
|
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 {
|
.leftindent {
|
||||||
margin-left: 1em;
|
margin-left: 1em;
|
||||||
margin-right: 0em;
|
margin-right: 0em;
|
||||||
|
|
|
@ -72,6 +72,7 @@
|
||||||
[element ([style any/c]
|
[element ([style any/c]
|
||||||
[content list?])]
|
[content list?])]
|
||||||
[(target-element element) ([tag tag?])]
|
[(target-element element) ([tag tag?])]
|
||||||
|
[(toc-target-element target-element) ()]
|
||||||
[(link-element element) ([tag tag?])]
|
[(link-element element) ([tag tag?])]
|
||||||
[(index-element element) ([tag tag?]
|
[(index-element element) ([tag tag?]
|
||||||
[plain-seq (listof string?)]
|
[plain-seq (listof string?)]
|
||||||
|
|
|
@ -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
|
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
|
primitive whose contract was assumed. If absent, it defaults to the
|
||||||
source location of the @scheme[contract] expression.}
|
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.}
|
||||||
|
|
||||||
|
|
|
@ -5,6 +5,7 @@
|
||||||
|
|
||||||
@local-table-of-contents[]
|
@local-table-of-contents[]
|
||||||
|
|
||||||
|
@include-section["values.scrbl"]
|
||||||
@include-section["exns.scrbl"]
|
@include-section["exns.scrbl"]
|
||||||
@include-section["cont.scrbl"]
|
@include-section["cont.scrbl"]
|
||||||
@include-section["cont-marks.scrbl"]
|
@include-section["cont-marks.scrbl"]
|
||||||
|
|
|
@ -119,7 +119,7 @@ specification of @tech{tail positions} goes with each syntactic form,
|
||||||
like @scheme[if].
|
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
|
A Scheme expression can evaluate to @deftech{multiple values}, in the
|
||||||
same way that a procedure can accept multiple arguments.
|
same way that a procedure can accept multiple arguments.
|
||||||
|
|
35
collects/scribblings/reference/values.scrbl
Normal file
35
collects/scribblings/reference/values.scrbl
Normal 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)))
|
||||||
|
]}
|
Loading…
Reference in New Issue
Block a user