commit 95ecb101d1cc61d212c4d52079bc17c39ffff730
parent 9618416c8ef5c5efd5709f83e7672fcd608b7ac8
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 30 Dec 2007 16:16:11 +0000
generalized defproc to support curried notation, start scribbling graphics collection docs
svn: r8164
original commit: 9c6c83d8d2d1d5f4881d6673107c7d4fc2b36808
Diffstat:
2 files changed, 236 insertions(+), 137 deletions(-)
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -531,6 +531,39 @@
[else
#'#f]))
+ (define-syntax (extract-proc-id stx)
+ (syntax-case stx ()
+ [(_ id)
+ (identifier? #'id)
+ #`(quote-syntax/loc id)]
+ [(_ (proto arg ...))
+ #'(extract-proc-id proto)]
+ [(_ thing)
+ (raise-syntax-error
+ 'defproc
+ "bad prototype"
+ #'thing)]))
+
+ (define-syntax (arg-contracts stx)
+ (syntax-case stx ()
+ [(_ id arg ...)
+ (identifier? #'id)
+ #'(list (lambda () (arg-contract arg)) ...)]
+ [(_ (proto arg1 ...) arg ...)
+ #'(arg-contracts proto arg1 ... arg ...)]
+ [_
+ (raise-syntax-error 'defproc "bad prototype" stx)]))
+
+ (define-syntax (arg-defaults stx)
+ (syntax-case stx ()
+ [(_ id arg ...)
+ (identifier? #'id)
+ #'(list (lambda () (arg-default arg)) ...)]
+ [(_ (proto arg1 ...) arg ...)
+ #'(arg-defaults proto arg1 ... arg ...)]
+ [_
+ (raise-syntax-error 'defproc "bad prototype" stx)]))
+
(define-syntax (result-contract stx)
(syntax-case stx ()
[(_ c)
@@ -547,14 +580,14 @@
(defproc* [[(id arg ...) result]] desc ...)]))
(define-syntax defproc*
(syntax-rules ()
- [(_ [[(id arg ...) result] ...] desc ...)
- (defproc* #:mode procedure #:within #f [[(id arg ...) result] ...] desc ...)]
- [(_ #:mode m #:within cl [[(id arg ...) result] ...] desc ...)
+ [(_ [[proto result] ...] desc ...)
+ (defproc* #:mode procedure #:within #f [[proto result] ...] desc ...)]
+ [(_ #:mode m #:within cl [[proto result] ...] desc ...)
(*defproc 'm (quote-syntax/loc cl)
- (list (quote-syntax/loc id) ...)
- '[(id arg ...) ...]
- (list (list (lambda () (arg-contract arg)) ...) ...)
- (list (list (lambda () (arg-default arg)) ...) ...)
+ (list (extract-proc-id proto) ...)
+ '[proto ...]
+ (list (arg-contracts proto) ...)
+ (list (arg-defaults proto) ...)
(list (lambda () (result-contract result)) ...)
(lambda () (list desc ...)))]))
(define-syntax defstruct
@@ -809,6 +842,8 @@
(define-syntax-rule (deftogether (box ...) . body)
(*deftogether (list box ...) (lambda () (list . body))))
+
+ (define-struct arg (special? kw id optional? starts-optional? ends-optional? num-closers))
(define (*defproc mode within-id
stx-ids prototypes arg-contractss arg-valss result-contracts content-thunk)
@@ -820,47 +855,130 @@
2))))]
[to-flow (lambda (e)
(make-flow (list (make-paragraph (list e)))))]
- [arg->elem (lambda (v)
- (cond
- [(pair? v)
- (if (keyword? (car v))
- (if (eq? mode 'new)
- (make-element #f (list (schemeparenfont "[")
- (schemeidfont (keyword->string (car v)))
- (hspace 1)
- (to-element (cadr v))
- (schemeparenfont "]")))
- (make-element #f (list (to-element (car v))
- (hspace 1)
- (to-element (cadr v)))))
- (to-element (car v)))]
- [(eq? v '...+)
- dots1]
- [(eq? v '...)
- dots0]
- [else v]))]
- [prototype-size (lambda (s first-combine next-combine)
- (let loop ([s s][combine first-combine])
- (if (null? s)
- 0
- (combine
- (loop (cdr s) next-combine)
- (cond
- [(symbol? (car s)) (string-length (symbol->string (car s)))]
- [(pair? (car s))
- (if (keyword? (caar s))
- (+ (if (eq? mode 'new) 2 0)
- (string-length (keyword->string (caar s)))
- 3
- (string-length (symbol->string (cadar s))))
- (string-length (symbol->string (caar s))))]
- [else 0])))))])
- (let ([var-list (map (lambda (i)
- (and (pair? i)
- (if (keyword? (car i))
- (cadr i)
- (car i))))
- (apply append (map cdr prototypes)))])
+ [arg->elem (lambda (show-opt-start?)
+ (lambda (arg)
+ (let* ([e (cond
+ [(not (arg-special? arg))
+ (if (arg-kw arg)
+ (if (eq? mode 'new)
+ (make-element #f (list (schemeparenfont "[")
+ (schemeidfont (keyword->string (arg-kw arg)))
+ (hspace 1)
+ (to-element (arg-id arg))
+ (schemeparenfont "]")))
+ (make-element #f (list (to-element (arg-kw arg))
+ (hspace 1)
+ (to-element (arg-id arg)))))
+ (to-element (arg-id arg)))]
+ [(eq? (arg-id arg) '...+)
+ dots1]
+ [(eq? (arg-id arg) '...)
+ dots0]
+ [else (arg-id arg)])]
+ [e (if (arg-ends-optional? arg)
+ (make-element #f (list e "]"))
+ e)]
+ [e (if (zero? (arg-num-closers arg))
+ e
+ (make-element #f
+ (list e
+ (schemeparenfont (make-string (arg-num-closers arg) #\))))))])
+ (if (and show-opt-start?
+ (arg-starts-optional? arg))
+ (make-element #f (list "[" e))
+ e))))]
+ [prototype-depth (lambda (p)
+ (let loop ([p (car p)])
+ (if (symbol? p)
+ 0
+ (+ 1 (loop (car p))))))]
+ [prototype-args (lambda (p)
+ (let ([parse-arg (lambda (v in-optional? depth next-optional? next-special?)
+ (let* ([id (if (pair? v)
+ (if (keyword? (car v))
+ (cadr v)
+ (car v))
+ v)]
+ [kw (if (and (pair? v)
+ (keyword? (car v)))
+ (car v)
+ #f)]
+ [default? (and (pair? v)
+ (let ([p (if kw
+ (cdddr v)
+ (cddr v))])
+ (pair? p)))])
+ (make-arg (symbol? v)
+ kw
+ id
+ default?
+ (and default?
+ (not in-optional?))
+ (or (and (not default?)
+ in-optional?) ; => must be special
+ (and default?
+ (not next-optional?)
+ (not next-special?)))
+ depth)))])
+ (let loop ([p p][last-depth 0])
+ (append (if (symbol? (car p))
+ null
+ (loop (car p) (add1 last-depth)))
+ (let loop ([p (cdr p)][in-optional? #f])
+ (cond
+ [(null? p) null]
+ [(null? (cdr p))
+ (list (parse-arg (car p)
+ in-optional?
+ last-depth
+ #f
+ #f))]
+ [else
+ (let ([a (parse-arg (car p)
+ in-optional?
+ 0
+ (let ([v (cadr p)])
+ (and (pair? v)
+ (not
+ (null?
+ ((if (keyword? (car v))
+ cdddr
+ cddr)
+ v)))))
+ (not (pair? (cadr p))))])
+ (cons a
+ (loop (cdr p)
+ (and (arg-optional? a)
+ (not (arg-ends-optional? a))))))]))))))]
+ [prototype-size (lambda (args first-combine next-combine)
+ (let loop ([s args][combine first-combine])
+ (if (null? s)
+ 0
+ (combine
+ (loop (cdr s) next-combine)
+ (let ([a (car s)])
+ (+ (arg-num-closers a)
+ (cond
+ [(arg-special? a)
+ (string-length (symbol->string (arg-id a)))]
+ [else
+ (+ (if (arg-kw a)
+ (+ (if (eq? mode 'new) 2 0)
+ (string-length (keyword->string (arg-kw a)))
+ 3
+ (string-length (symbol->string (arg-id a))))
+ (string-length (symbol->string (arg-id a)))))])))))))]
+ [extract-id (lambda (p)
+ (let loop ([p p])
+ (if (symbol? (car p))
+ (car p)
+ (loop (car p)))))])
+ (let* ([all-args (map prototype-args prototypes)]
+ [var-list (filter values
+ (map (lambda (a)
+ (and (not (arg-special? a))
+ (arg-id a)))
+ (apply append all-args)))])
(parameterize ([current-variable-list var-list])
(make-box-splice
(cons
@@ -869,24 +987,8 @@
(apply
append
(map
- (lambda (stx-id prototype arg-contracts arg-vals result-contract first?)
- (let*-values ([(required optional more-required)
- (let loop ([a (cdr prototype)][r-accum null])
- (if (or (null? a)
- (and (has-optional? (car a))))
- (let ([req (reverse r-accum)])
- (let loop ([a a][o-accum null])
- (if (or (null? a)
- (and (not (has-optional? (car a)))
- ;; A repeat after an optional argument is
- ;; effectively optional:
- (not (memq (car a) '(...)))
- (or (null? (cdr a))
- (not (memq (cadr a) '(...))))))
- (values req (reverse o-accum) a)
- (loop (cdr a) (cons (car a) o-accum)))))
- (loop (cdr a) (cons (car a) r-accum))))]
- [(tagged) (cond
+ (lambda (stx-id prototype args arg-contracts arg-vals result-contract first?)
+ (let*-values ([(tagged) (cond
[(eq? mode 'new)
(make-element #f
(list (scheme new)
@@ -904,7 +1006,7 @@
(name-this-object (syntax-e within-id))
(hspace 1)
(if first?
- (let* ([mname (car prototype)]
+ (let* ([mname (extract-id prototype)]
[ctag (id-to-tag within-id)]
[tag (method-tag ctag mname)]
[content (list (*method mname within-id))])
@@ -925,45 +1027,46 @@
ctag)))))
tag)
(car content)))
- (*method (car prototype) within-id))))]
+ (*method (extract-id prototype) within-id))))]
[else
(if first?
(let ([tag (id-to-tag stx-id)]
- [content (list (definition-site (car prototype) stx-id #f))])
+ [content (list (definition-site (extract-id prototype) stx-id #f))])
(if tag
(make-toc-target-element
#f
(list (make-index-element #f
content
tag
- (list (symbol->string (car prototype)))
+ (list (symbol->string (extract-id prototype)))
content
(with-exporting-libraries
(lambda (libs)
(make-procedure-index-desc
- (car prototype)
+ (extract-id prototype)
libs)))))
tag)
(car content)))
(annote-exporting-library
- (to-element (make-just-context (car prototype)
+ (to-element (make-just-context (extract-id prototype)
stx-id))))])]
- [(flat-size) (+ (prototype-size (cdr prototype) + +)
+ [(flat-size) (+ (prototype-size args + +)
+ (prototype-depth prototype)
(element-width tagged))]
[(short?) (or (flat-size . < . 40)
- ((length prototype) . < . 3))]
+ ((length args) . < . 2))]
[(res) (result-contract)]
[(result-next-line?) ((+ (if short?
flat-size
- (+ (prototype-size (cdr prototype) max max)
+ (+ (prototype-size args max max)
+ (prototype-depth prototype)
(element-width tagged)))
(flow-element-width res))
. >= . (- max-proto-width 7))]
[(end) (list (to-flow spacer)
(to-flow 'rarr)
(to-flow spacer)
- (make-flow (list res)))]
- [(opt-cnt) (length optional)])
+ (make-flow (list res)))])
(append
(list
(list (make-flow
@@ -973,18 +1076,24 @@
(list
(cons
(to-flow
- (to-element (append
- (list tagged)
- (map arg->elem required)
- (if (null? optional)
- null
- (list
- (to-element
- (syntax-property
- (syntax-ize (map arg->elem optional) 0)
- 'paren-shape
- #\?))))
- (map arg->elem more-required))))
+ (make-element
+ #f
+ (append
+ (list
+ (schemeparenfont (make-string (add1 (prototype-depth prototype)) #\())
+ tagged)
+ (if (null? args)
+ (list
+ (schemeparenfont (make-string (add1 (prototype-depth prototype)) #\))))
+ (apply
+ append
+ (map
+ (lambda (arg)
+ (list
+ spacer
+ ((arg->elem #t) arg)))
+ args)))
+ (list (schemeparenfont ")")))))
(if result-next-line?
null
end))))
@@ -1002,48 +1111,36 @@
(list* (to-flow (make-element
#f
(list
- (schemeparenfont "(")
+ (schemeparenfont (make-string (add1 (prototype-depth prototype)) #\())
tagged)))
(cond
- [(null? required)
+ [(arg-starts-optional? (car args))
(to-flow (make-element #f (list spacer "[")))]
[else
(to-flow spacer)])
(to-flow
- (if (null? required)
- (arg->elem (car optional))
- (arg->elem (car required))))
+ ((arg->elem #f) (car args)))
not-end)
- (let loop ([args (cdr (append required optional more-required))]
- [req (sub1 (length required))])
+ (let loop ([args (cdr args)])
(if (null? args)
null
(let ([dots-next? (or (and (pair? (cdr args))
- (or (eq? (cadr args) '...)
- (eq? (cadr args) '...+))))])
+ (arg-special? (cadr args))))])
(cons (list* (to-flow spacer)
- (if (zero? req)
+ (if (arg-starts-optional? (car args))
(to-flow (make-element #f (list spacer "[")))
(to-flow spacer))
- (let ([a (arg->elem (car args))]
+ (let ([a ((arg->elem #f) (car args))]
[next (if dots-next?
(make-element #f (list (hspace 1)
- (arg->elem (cadr args))))
+ ((arg->elem #f) (cadr args))))
"")])
(to-flow
(cond
[(null? ((if dots-next? cddr cdr) args))
- (if (or (null? optional)
- (not (null? more-required)))
- (make-element
- #f
- (list a next (schemeparenfont ")")))
- (make-element
- #f
- (list a next "]" (schemeparenfont ")"))))]
- [(and (pair? more-required)
- (= (- 1 req) (length optional)))
- (make-element #f (list a next "]"))]
+ (make-element
+ #f
+ (list a next (schemeparenfont ")")))]
[(equal? next "") a]
[else
(make-element #f (list a next))])))
@@ -1051,30 +1148,27 @@
(not result-next-line?))
end
not-end))
- (loop ((if dots-next? cddr cdr) args) (sub1 req))))))))))))))
+ (loop ((if dots-next? cddr cdr) args))))))))))))))
(if result-next-line?
(list (list (make-flow (make-table-if-necessary
"prototype"
(list end)))))
null)
(apply append
- (map (lambda (v arg-contract arg-val)
+ (map (lambda (arg arg-contract arg-val)
(cond
- [(pair? v)
- (let* ([v (if (keyword? (car v))
- (cdr v)
- v)]
- [arg-cont (arg-contract)]
- [base-len (+ 5 (string-length (symbol->string (car v)))
+ [(not (arg-special? arg))
+ (let* ([arg-cont (arg-contract)]
+ [base-len (+ 5 (string-length (symbol->string (arg-id arg)))
(flow-element-width arg-cont))]
[arg-val (and arg-val (arg-val))]
- [def-len (if (has-optional? v)
+ [def-len (if (arg-optional? arg)
(flow-element-width arg-val)
0)]
[base-list
(list
(to-flow (hspace 2))
- (to-flow (arg->elem v))
+ (to-flow (to-element (arg-id arg)))
(to-flow spacer)
(to-flow ":")
(to-flow spacer)
@@ -1082,7 +1176,7 @@
(list
(list
(make-flow
- (if (and (has-optional? v)
+ (if (and (arg-optional? arg)
((+ base-len 3 def-len) . >= . max-proto-width))
(list
(make-table
@@ -1101,7 +1195,7 @@
(list
(append
base-list
- (if (and (has-optional? v)
+ (if (and (arg-optional? arg)
((+ base-len 3 def-len) . < . max-proto-width))
(list (to-flow spacer)
(to-flow "=")
@@ -1109,22 +1203,23 @@
(make-flow (list arg-val)))
null)))))))))]
[else null]))
- (cdr prototype)
+ args
arg-contracts
arg-vals)))))
stx-ids
prototypes
+ all-args
arg-contractss
arg-valss
result-contracts
(let loop ([ps prototypes][accum null])
(cond
[(null? ps) null]
- [(ormap (lambda (a) (eq? (caar ps) a)) accum)
+ [(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum)
(cons #f (loop (cdr ps) accum))]
[else
(cons #t (loop (cdr ps)
- (cons (caar ps) accum)))])))))
+ (cons (extract-id (car ps)) accum)))])))))
(content-thunk))
var-list)))))
diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl
@@ -237,21 +237,25 @@ hovers the mouse over one of the bindings defined within the section.}
@; ------------------------------------------------------------------------
@section{Documenting Forms, Functions, Structure Types, and Values}
-@defform/subs[(defproc (id arg-spec ...)
+@defform/subs[(defproc prototype
result-contract-expr-datum
pre-flow ...)
- ([arg-spec (arg-id contract-expr-datum)
+ ([prototype id
+ (prototype arg-spec ...)]
+ [arg-spec (arg-id contract-expr-datum)
(arg-id contract-expr-datum default-expr)
(keyword arg-id contract-expr-datum)
(keyword arg-id contract-expr-datum default-expr)])]{
-Produces a sequence of flow elements (encapsulated in a @scheme[splice])
-to document a procedure named @scheme[id]. The @scheme[id] is indexed,
-and it also registered so that @scheme[scheme]-typeset uses of the
-identifier (with the same for-label binding) are hyperlinked to this
-documentation. The @scheme[id] should have a for-label binding (as
-introduced by @scheme[require-for-label]) that determines the module
-binding being defined.
+Produces a sequence of flow elements (encapsulated in a
+@scheme[splice]) to document a procedure named @scheme[id]. Nesting
+@scheme[prototype]s corresponds to a curried function, as in
+@scheme[define]. The @scheme[id] is indexed, and it also registered so
+that @scheme[scheme]-typeset uses of the identifier (with the same
+for-label binding) are hyperlinked to this documentation. The
+@scheme[id] should have a for-label binding (as introduced by
+@scheme[require-for-label]) that determines the module binding being
+defined.
Each @scheme[arg-spec] must have one of the following forms:
@@ -291,7 +295,7 @@ ignores the source layout, except that the local formatting is
preserved for contracts and default-values expressions.}
-@defform[(defproc* ([(id arg-spec ...)
+@defform[(defproc* ([prototype
result-contract-expr-datum] ...)
pre-flow ...)]{
