suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

PR 10431, plus support for ->* with keywords in proc-doc

Browse Source 
svn: r15926

original commit: 390145821a65565c569afa8ad8a249b1508902ef
This commit is contained in:
Robby Findler 2009-09-08 22:53:12 +00:00
parent 60dd2c85c7
commit 51471523cf
2 changed files with 57 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
collects/scribble/srcdoc.ss
View File

@ -117,15 +117,55 @@
(syntax-case #'names ()
[((mandatory-names ...)
((optional-names optional-default) ...))
(begin
(unless (= (length (syntax->list #'(mandatory-names ...)))
(length (syntax->list #'(mandatory ...))))
(raise-syntax-error #f "mismatched mandatory argument list and domain contract count" stx))
(unless (= (length (syntax->list #'(optional-names ...)))
(length (syntax->list #'(optional ...))))
(raise-syntax-error #f "mismatched mandatory argument list and domain contract count" stx))
#'([(id (mandatory-names mandatory) ... (optional-names optional optional-default) ...)
result]))]
(let ([build-mandatories/optionals
(λ (names contracts extras)
(let ([names-length (length names)]
[contracts-length (length contracts)])
(let loop ([contracts contracts]
[names names]
[extras extras])
(cond
[(and (null? names) (null? contracts)) '()]
[(or (null? names) (null? contracts))
(raise-syntax-error #f
(format "mismatched ~a argument list count and domain contract count (~a)"
(if extras "optional" "mandatory")
(if (null? names)
"ran out of names"
"ran out of contracts"))
stx)]
[else
(let ([fst-name (car names)]
[fst-ctc (car contracts)])
(if (keyword? (syntax-e fst-ctc))
(begin
(unless (pair? (cdr contracts))
(raise-syntax-error #f
"keyword not followed by a contract"
stx))
(cons (if extras
(list fst-ctc fst-name (cadr contracts) (car extras))
(list fst-ctc fst-name (cadr contracts)))
(loop (cddr contracts)
(cdr names)
(if extras
(cdr extras)
extras))))
(cons (if extras
(list fst-name fst-ctc (car extras))
(list fst-name fst-ctc))
(loop (cdr contracts) (cdr names) (if extras
(cdr extras)
extras)))))]))))])
#`([(id #,@(build-mandatories/optionals (syntax->list #'(mandatory-names ...))
(syntax->list #'(mandatory ...))
#f)
#,@(build-mandatories/optionals (syntax->list #'(optional-names ...))
(syntax->list #'(optional ...))
(syntax->list #'(optional-default ...))))
result]))]
[(mandatory-names optional-names)
(begin
(syntax-case #'mandatory-names ()

11
collects/scribblings/scribble/srcdoc.scrbl
View File

@ -71,10 +71,14 @@ to get core Scheme forms and basic Scribble functions to use in
documentation expressions.}
@defform*/subs[#:literals (-> ->* case->)
[(proc-doc/names id contract (arg-id ...) desc-expr)
(proc-doc/names id case-contract ((arg-id ...) ...) desc-expr)]
[(proc-doc/names id contract ((arg-id ...) ((arg-id default-expr) ...)) desc-expr)
(proc-doc/names id case-contract ((arg-id ...) ((arg-id default-expr) ...)) desc-expr)]
([contract (-> arg ... result)
(->* (mandatory ...) (optional ...) result)]
[mandatory contract-expr
(code:line keyword contract-expr)]
[optional contract-expr
(code:line keyword contract-expr)]
[case-contract (case-> (-> arg ... result) ...)])]{
When used in @scheme[provide/doc], exports @scheme[id] with the
@ -84,7 +88,8 @@ just like using @scheme[provide/contract].
The @scheme[arg-id]s specify the names of arguments, which are not
normally written as part of a contract. They are combined with the
contract expression to generate the description of the binding in the
documentation via @scheme[defproc].
documentation via @scheme[defproc]. The @scheme[(arg-id default-expr)]
pairs specify the names and default values of the optional arguments.
The @scheme[desc-expr] is a documentation-time expression that
produces prose to describe the exported binding---that is, the last