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

ported the documentation for the framework's test library -- also extended srcdoc.ss a little bit

Browse Source 
svn: r9499

original commit: 6a53f96e06fbf7a23d7eb40c35a711e9de103eaf
This commit is contained in:
Robby Findler 2008-04-27 02:55:21 +00:00
parent bcf264af6e
commit be139203c1
1 changed files with 67 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
collects/scribble/srcdoc.ss
View File

@ -6,7 +6,9 @@
(provide require/doc
provide/doc
proc-doc)
parameter-doc
proc-doc
proc-doc/names)
(define-syntax-rule (require/doc spec ...)
(void (quote-syntax (require/doc spec ...))))
@ -53,26 +55,18 @@
(lambda (stx)
(syntax-case stx ()
[(_ id contract desc)
(with-syntax ([(arg ...)
(syntax-case #'contract (->d)
[(->d (req ...) () result)
#'(req ...)]
(with-syntax ([((arg ...) result)
(syntax-case #'contract (->d -> values)
[(->d (req ...) () (values [name res] ...))
#'((req ...) (values res ...))]
[(->d (req ...) () [name res])
#'((req ...) res)]
[(-> result)
#'(() result)]
[else
(raise-syntax-error
#f
"unsupported procedure contract form (arguments)"
stx
#'contract)])]
[result
(syntax-case #'contract (->d)
[(->d reqs opts (values [name res] ...))
#'(values res ...)]
[(->d reqs opts [name res])
#'res]
[else
(raise-syntax-error
#f
"unsupported procedure contract form (arguments)"
"unsupported procedure contract form (no argument names)"
stx
#'contract)])])
(values
@ -80,4 +74,58 @@
#'(defproc (id arg ...) result . desc)
#'(scribble/manual)))])))
(define-provide/doc-transformer proc-doc/names
(lambda (stx)
(syntax-case stx ()
[(_ id contract names desc)
(with-syntax ([header
(syntax-case #'(contract names) (->d -> values)
[((-> ctcs ... result) (arg-names ...))
(begin
(unless (= (length (syntax->list #'(ctcs ...)))
(length (syntax->list #'(arg-names ...))))
(raise-syntax-error #f "mismatched argument list and domain contract count" stx))
#'([(id (arg-names ctcs) ...) result]))]
[((->* (mandatory ...) (optional ...) result)
((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]))]
[((case-> (-> doms ... rng) ...)
((args ...) ...))
(begin
(for-each
(λ (doms args)
(unless (= (length (syntax->list doms))
(length (syntax->list args)))
(raise-syntax-error #f "mismatched case argument list and domain contract" stx)))
(syntax->list #'((doms ...) ...))
(syntax->list #'((args ...) ...)))
#'([(id (args doms) ...) rng] ...))]
[else
(raise-syntax-error
#f
"unsupported procedure contract form (no argument names)"
stx
#'contract)])])
(values
#'[id contract]
#'(defproc* header . desc)
#'(scribble/manual)))])))
(define-provide/doc-transformer parameter-doc
(lambda (stx)
(syntax-case stx (parameter/c)
[(_ id (parameter/c contract) arg-id desc)
(values
#'[id (parameter/c contract)]
#'(defparam id arg-id contract . desc)
#'(scribble/manual))])))