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

generalized defproc to support curried notation, start scribbling graphics collection docs

Browse Source 
svn: r8164

original commit: 9c6c83d8d2d1d5f4881d6673107c7d4fc2b36808
This commit is contained in:
Matthew Flatt 2007-12-30 16:16:11 +00:00
parent 9618416c8e
commit 95ecb101d1
2 changed files with 236 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

349
collects/scribble/manual.ss
View File

@ -531,6 +531,39 @@
[else [else
#'#f])) #'#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) (define-syntax (result-contract stx)
(syntax-case stx () (syntax-case stx ()
[(_ c) [(_ c)
@ -547,14 +580,14 @@
(defproc* [[(id arg ...) result]] desc ...)])) (defproc* [[(id arg ...) result]] desc ...)]))
(define-syntax defproc* (define-syntax defproc*
(syntax-rules () (syntax-rules ()
[(_ [[(id arg ...) result] ...] desc ...) [(_ [[proto result] ...] desc ...)
(defproc* #:mode procedure #:within #f [[(id arg ...) result] ...] desc ...)] (defproc* #:mode procedure #:within #f [[proto result] ...] desc ...)]
[(_ #:mode m #:within cl [[(id arg ...) result] ...] desc ...) [(_ #:mode m #:within cl [[proto result] ...] desc ...)
(*defproc 'm (quote-syntax/loc cl) (*defproc 'm (quote-syntax/loc cl)
(list (quote-syntax/loc id) ...) (list (extract-proc-id proto) ...)
'[(id arg ...) ...] '[proto ...]
(list (list (lambda () (arg-contract arg)) ...) ...) (list (arg-contracts proto) ...)
(list (list (lambda () (arg-default arg)) ...) ...) (list (arg-defaults proto) ...)
(list (lambda () (result-contract result)) ...) (list (lambda () (result-contract result)) ...)
(lambda () (list desc ...)))])) (lambda () (list desc ...)))]))
(define-syntax defstruct (define-syntax defstruct
@ -809,6 +842,8 @@
(define-syntax-rule (deftogether (box ...) . body) (define-syntax-rule (deftogether (box ...) . body)
(*deftogether (list box ...) (lambda () (list . 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 (define (*defproc mode within-id
stx-ids prototypes arg-contractss arg-valss result-contracts content-thunk) stx-ids prototypes arg-contractss arg-valss result-contracts content-thunk)
@ -820,47 +855,130 @@
2))))] 2))))]
[to-flow (lambda (e) [to-flow (lambda (e)
(make-flow (list (make-paragraph (list e)))))] (make-flow (list (make-paragraph (list e)))))]
[arg->elem (lambda (v) [arg->elem (lambda (show-opt-start?)
(cond (lambda (arg)
[(pair? v) (let* ([e (cond
(if (keyword? (car v)) [(not (arg-special? arg))
(if (eq? mode 'new) (if (arg-kw arg)
(make-element #f (list (schemeparenfont "[") (if (eq? mode 'new)
(schemeidfont (keyword->string (car v))) (make-element #f (list (schemeparenfont "[")
(hspace 1) (schemeidfont (keyword->string (arg-kw arg)))
(to-element (cadr v)) (hspace 1)
(schemeparenfont "]"))) (to-element (arg-id arg))
(make-element #f (list (to-element (car v)) (schemeparenfont "]")))
(hspace 1) (make-element #f (list (to-element (arg-kw arg))
(to-element (cadr v))))) (hspace 1)
(to-element (car v)))] (to-element (arg-id arg)))))
[(eq? v '...+) (to-element (arg-id arg)))]
dots1] [(eq? (arg-id arg) '...+)
[(eq? v '...) dots1]
dots0] [(eq? (arg-id arg) '...)
[else v]))] dots0]
[prototype-size (lambda (s first-combine next-combine) [else (arg-id arg)])]
(let loop ([s s][combine first-combine]) [e (if (arg-ends-optional? arg)
(if (null? s) (make-element #f (list e "]"))
0 e)]
(combine [e (if (zero? (arg-num-closers arg))
(loop (cdr s) next-combine) e
(cond (make-element #f
[(symbol? (car s)) (string-length (symbol->string (car s)))] (list e
[(pair? (car s)) (schemeparenfont (make-string (arg-num-closers arg) #\))))))])
(if (keyword? (caar s)) (if (and show-opt-start?
(+ (if (eq? mode 'new) 2 0) (arg-starts-optional? arg))
(string-length (keyword->string (caar s))) (make-element #f (list "[" e))
3 e))))]
(string-length (symbol->string (cadar s)))) [prototype-depth (lambda (p)
(string-length (symbol->string (caar s))))] (let loop ([p (car p)])
[else 0])))))]) (if (symbol? p)
(let ([var-list (map (lambda (i) 0
(and (pair? i) (+ 1 (loop (car p))))))]
(if (keyword? (car i)) [prototype-args (lambda (p)
(cadr i) (let ([parse-arg (lambda (v in-optional? depth next-optional? next-special?)
(car i)))) (let* ([id (if (pair? v)
(apply append (map cdr prototypes)))]) (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]) (parameterize ([current-variable-list var-list])
(make-box-splice (make-box-splice
(cons (cons
@ -869,24 +987,8 @@
(apply (apply
append append
(map (map
(lambda (stx-id prototype arg-contracts arg-vals result-contract first?) (lambda (stx-id prototype args arg-contracts arg-vals result-contract first?)
(let*-values ([(required optional more-required) (let*-values ([(tagged) (cond
(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
[(eq? mode 'new) [(eq? mode 'new)
(make-element #f (make-element #f
(list (scheme new) (list (scheme new)
@ -904,7 +1006,7 @@
(name-this-object (syntax-e within-id)) (name-this-object (syntax-e within-id))
(hspace 1) (hspace 1)
(if first? (if first?
(let* ([mname (car prototype)] (let* ([mname (extract-id prototype)]
[ctag (id-to-tag within-id)] [ctag (id-to-tag within-id)]
[tag (method-tag ctag mname)] [tag (method-tag ctag mname)]
[content (list (*method mname within-id))]) [content (list (*method mname within-id))])
@ -925,45 +1027,46 @@
ctag))))) ctag)))))
tag) tag)
(car content))) (car content)))
(*method (car prototype) within-id))))] (*method (extract-id prototype) within-id))))]
[else [else
(if first? (if first?
(let ([tag (id-to-tag stx-id)] (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 (if tag
(make-toc-target-element (make-toc-target-element
#f #f
(list (make-index-element #f (list (make-index-element #f
content content
tag tag
(list (symbol->string (car prototype))) (list (symbol->string (extract-id prototype)))
content content
(with-exporting-libraries (with-exporting-libraries
(lambda (libs) (lambda (libs)
(make-procedure-index-desc (make-procedure-index-desc
(car prototype) (extract-id prototype)
libs))))) libs)))))
tag) tag)
(car content))) (car content)))
(annote-exporting-library (annote-exporting-library
(to-element (make-just-context (car prototype) (to-element (make-just-context (extract-id prototype)
stx-id))))])] stx-id))))])]
[(flat-size) (+ (prototype-size (cdr prototype) + +) [(flat-size) (+ (prototype-size args + +)
(prototype-depth prototype)
(element-width tagged))] (element-width tagged))]
[(short?) (or (flat-size . < . 40) [(short?) (or (flat-size . < . 40)
((length prototype) . < . 3))] ((length args) . < . 2))]
[(res) (result-contract)] [(res) (result-contract)]
[(result-next-line?) ((+ (if short? [(result-next-line?) ((+ (if short?
flat-size flat-size
(+ (prototype-size (cdr prototype) max max) (+ (prototype-size args max max)
(prototype-depth prototype)
(element-width tagged))) (element-width tagged)))
(flow-element-width res)) (flow-element-width res))
. >= . (- max-proto-width 7))] . >= . (- max-proto-width 7))]
[(end) (list (to-flow spacer) [(end) (list (to-flow spacer)
(to-flow 'rarr) (to-flow 'rarr)
(to-flow spacer) (to-flow spacer)
(make-flow (list res)))] (make-flow (list res)))])
[(opt-cnt) (length optional)])
(append (append
(list (list
(list (make-flow (list (make-flow
@ -973,18 +1076,24 @@
(list (list
(cons (cons
(to-flow (to-flow
(to-element (append (make-element
(list tagged) #f
(map arg->elem required) (append
(if (null? optional) (list
null (schemeparenfont (make-string (add1 (prototype-depth prototype)) #\())
(list tagged)
(to-element (if (null? args)
(syntax-property (list
(syntax-ize (map arg->elem optional) 0) (schemeparenfont (make-string (add1 (prototype-depth prototype)) #\))))
'paren-shape (apply
#\?)))) append
(map arg->elem more-required)))) (map
(lambda (arg)
(list
spacer
((arg->elem #t) arg)))
args)))
(list (schemeparenfont ")")))))
(if result-next-line? (if result-next-line?
null null
end)))) end))))
@ -1002,48 +1111,36 @@
(list* (to-flow (make-element (list* (to-flow (make-element
#f #f
(list (list
(schemeparenfont "(") (schemeparenfont (make-string (add1 (prototype-depth prototype)) #\())
tagged))) tagged)))
(cond (cond
[(null? required) [(arg-starts-optional? (car args))
(to-flow (make-element #f (list spacer "[")))] (to-flow (make-element #f (list spacer "[")))]
[else [else
(to-flow spacer)]) (to-flow spacer)])
(to-flow (to-flow
(if (null? required) ((arg->elem #f) (car args)))
(arg->elem (car optional))
(arg->elem (car required))))
not-end) not-end)
(let loop ([args (cdr (append required optional more-required))] (let loop ([args (cdr args)])
[req (sub1 (length required))])
(if (null? args) (if (null? args)
null null
(let ([dots-next? (or (and (pair? (cdr args)) (let ([dots-next? (or (and (pair? (cdr args))
(or (eq? (cadr args) '...) (arg-special? (cadr args))))])
(eq? (cadr args) '...+))))])
(cons (list* (to-flow spacer) (cons (list* (to-flow spacer)
(if (zero? req) (if (arg-starts-optional? (car args))
(to-flow (make-element #f (list spacer "["))) (to-flow (make-element #f (list spacer "[")))
(to-flow spacer)) (to-flow spacer))
(let ([a (arg->elem (car args))] (let ([a ((arg->elem #f) (car args))]
[next (if dots-next? [next (if dots-next?
(make-element #f (list (hspace 1) (make-element #f (list (hspace 1)
(arg->elem (cadr args)))) ((arg->elem #f) (cadr args))))
"")]) "")])
(to-flow (to-flow
(cond (cond
[(null? ((if dots-next? cddr cdr) args)) [(null? ((if dots-next? cddr cdr) args))
(if (or (null? optional) (make-element
(not (null? more-required))) #f
(make-element (list a next (schemeparenfont ")")))]
#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 "]"))]
[(equal? next "") a] [(equal? next "") a]
[else [else
(make-element #f (list a next))]))) (make-element #f (list a next))])))
@ -1051,30 +1148,27 @@
(not result-next-line?)) (not result-next-line?))
end end
not-end)) not-end))
(loop ((if dots-next? cddr cdr) args) (sub1 req)))))))))))))) (loop ((if dots-next? cddr cdr) args))))))))))))))
(if result-next-line? (if result-next-line?
(list (list (make-flow (make-table-if-necessary (list (list (make-flow (make-table-if-necessary
"prototype" "prototype"
(list end))))) (list end)))))
null) null)
(apply append (apply append
(map (lambda (v arg-contract arg-val) (map (lambda (arg arg-contract arg-val)
(cond (cond
[(pair? v) [(not (arg-special? arg))
(let* ([v (if (keyword? (car v)) (let* ([arg-cont (arg-contract)]
(cdr v) [base-len (+ 5 (string-length (symbol->string (arg-id arg)))
v)]
[arg-cont (arg-contract)]
[base-len (+ 5 (string-length (symbol->string (car v)))
(flow-element-width arg-cont))] (flow-element-width arg-cont))]
[arg-val (and arg-val (arg-val))] [arg-val (and arg-val (arg-val))]
[def-len (if (has-optional? v) [def-len (if (arg-optional? arg)
(flow-element-width arg-val) (flow-element-width arg-val)
0)] 0)]
[base-list [base-list
(list (list
(to-flow (hspace 2)) (to-flow (hspace 2))
(to-flow (arg->elem v)) (to-flow (to-element (arg-id arg)))
(to-flow spacer) (to-flow spacer)
(to-flow ":") (to-flow ":")
(to-flow spacer) (to-flow spacer)
@ -1082,7 +1176,7 @@
(list (list
(list (list
(make-flow (make-flow
(if (and (has-optional? v) (if (and (arg-optional? arg)
((+ base-len 3 def-len) . >= . max-proto-width)) ((+ base-len 3 def-len) . >= . max-proto-width))
(list (list
(make-table (make-table
@ -1101,7 +1195,7 @@
(list (list
(append (append
base-list base-list
(if (and (has-optional? v) (if (and (arg-optional? arg)
((+ base-len 3 def-len) . < . max-proto-width)) ((+ base-len 3 def-len) . < . max-proto-width))
(list (to-flow spacer) (list (to-flow spacer)
(to-flow "=") (to-flow "=")
@ -1109,22 +1203,23 @@
(make-flow (list arg-val))) (make-flow (list arg-val)))
null)))))))))] null)))))))))]
[else null])) [else null]))
(cdr prototype) args
arg-contracts arg-contracts
arg-vals))))) arg-vals)))))
stx-ids stx-ids
prototypes prototypes
all-args
arg-contractss arg-contractss
arg-valss arg-valss
result-contracts result-contracts
(let loop ([ps prototypes][accum null]) (let loop ([ps prototypes][accum null])
(cond (cond
[(null? ps) null] [(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))] (cons #f (loop (cdr ps) accum))]
[else [else
(cons #t (loop (cdr ps) (cons #t (loop (cdr ps)
(cons (caar ps) accum)))]))))) (cons (extract-id (car ps)) accum)))])))))
(content-thunk)) (content-thunk))
var-list))))) var-list)))))

24
collects/scribblings/scribble/manual.scrbl
View File

@ -237,21 +237,25 @@ hovers the mouse over one of the bindings defined within the section.}
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@section{Documenting Forms, Functions, Structure Types, and Values} @section{Documenting Forms, Functions, Structure Types, and Values}
@defform/subs[(defproc (id arg-spec ...) @defform/subs[(defproc prototype
result-contract-expr-datum result-contract-expr-datum
pre-flow ...) 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) (arg-id contract-expr-datum default-expr)
(keyword arg-id contract-expr-datum) (keyword arg-id contract-expr-datum)
(keyword arg-id contract-expr-datum default-expr)])]{ (keyword arg-id contract-expr-datum default-expr)])]{
Produces a sequence of flow elements (encapsulated in a @scheme[splice]) Produces a sequence of flow elements (encapsulated in a
to document a procedure named @scheme[id]. The @scheme[id] is indexed, @scheme[splice]) to document a procedure named @scheme[id]. Nesting
and it also registered so that @scheme[scheme]-typeset uses of the @scheme[prototype]s corresponds to a curried function, as in
identifier (with the same for-label binding) are hyperlinked to this @scheme[define]. The @scheme[id] is indexed, and it also registered so
documentation. The @scheme[id] should have a for-label binding (as that @scheme[scheme]-typeset uses of the identifier (with the same
introduced by @scheme[require-for-label]) that determines the module for-label binding) are hyperlinked to this documentation. The
binding being defined. @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: 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.} preserved for contracts and default-values expressions.}
@defform[(defproc* ([(id arg-spec ...) @defform[(defproc* ([prototype
result-contract-expr-datum] ...) result-contract-expr-datum] ...)
pre-flow ...)]{ pre-flow ...)]{