diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
index dcbbe346..56f02ec6 100644
--- a/collects/scribble/html-render.ss
+++ b/collects/scribble/html-render.ss
@@ -136,7 +136,8 @@
(define/override (render-element e part ht)
(cond
[(target-element? e)
- `((a ((name ,(target-element-tag e))) ,@(render-plain-element e part ht)))]
+ `((a ((name ,(target-element-tag e))))
+ ,@(render-plain-element e part ht))]
[(and (link-element? e)
(not (current-no-links)))
(parameterize ([current-no-links #t])
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
index 3f15245e..d6728300 100644
--- a/collects/scribble/manual.ss
+++ b/collects/scribble/manual.ss
@@ -17,9 +17,11 @@
(define-code schemeblock0 to-paragraph)
(define-code schemeblock (to-paragraph/prefix (hspace 2)
- (hspace 2)))
+ (hspace 2)
+ ""))
(define-code SCHEMEBLOCK (to-paragraph/prefix (hspace 2)
- (hspace 2))
+ (hspace 2)
+ "")
UNSYNTAX)
(define-code SCHEMEBLOCK0 to-paragraph UNSYNTAX)
(define-code schemeinput (to-paragraph/prefix (make-element
@@ -27,7 +29,8 @@
(list
(hspace 2)
(make-element 'tt (list "> " ))))
- (hspace 4)))
+ (hspace 4)
+ ""))
(define-syntax (schememod stx)
(syntax-case stx ()
@@ -161,45 +164,75 @@
(define dots1
(make-element #f (list "..." (superscript "+"))))
+ (define (to-paragraph/suffix s)
+ (to-paragraph/prefix ""
+ ""
+ (schemeparenfont s)))
+
+ (define-code schemeblock0/close (to-paragraph/suffix ")"))
+ (define-code schemeblock0/close... (to-paragraph/suffix ") ..."))
+ (define-code schemeblock0/close...+ (to-paragraph/suffix ") ...+"))
+ (define-code schemeblock0/closeclose (to-paragraph/suffix "))"))
+ (define-code schemeblock0/close...close (to-paragraph/suffix ") ...)"))
+ (define-code schemeblock0/close...+close (to-paragraph/suffix ") ...+)"))
+
(define-syntax (arg-contract stx)
(syntax-case stx (... ...+)
- [(_ [id contract])
+ [(_ [id contract] typeset)
(identifier? #'id)
- #'(schemeblock0 contract)]
- [(_ [id contract val])
+ #'(typeset contract)]
+ [(_ [id contract val] typeset)
(identifier? #'id)
- #'(schemeblock0 contract)]
- [(_ [kw id contract])
+ #'(typeset contract)]
+ [(_ [kw id contract] typeset)
(and (keyword? (syntax-e #'kw))
(identifier? #'id))
- #'(schemeblock0 contract)]
- [(_ [kw id contract val])
+ #'(typeset contract)]
+ [(_ [kw id contract val] typeset)
(and (keyword? (syntax-e #'kw))
(identifier? #'id))
- #'(schemeblock0 contract)]
- [(_ (... ...))
+ #'(typeset contract)]
+ [(_ (... ...) typeset)
#'#f]
- [(_ (... ...+))
+ [(_ (... ...+) typeset)
#'#f]
- [(_ arg)
+ [(_ arg typeset)
(raise-syntax-error
'defproc
"bad argument form"
#'arg)]))
-
+
+ (define-syntax arg-contracts
+ (syntax-rules (... ...+)
+ [(_) null]
+ [(_ arg (... ...))
+ (list (lambda () (arg-contract arg schemeblock0/close...close)))]
+ [(_ arg (... ...+))
+ (list (lambda () (arg-contract arg schemeblock0/close...+close)))]
+ [(_ arg (... ...) . rest)
+ (cons (lambda () (arg-contract arg schemeblock0/close...))
+ (arg-contracts . rest))]
+ [(_ arg (... ...+) . rest)
+ (cons (lambda () (arg-contract arg schemeblock0/close...+))
+ (arg-contracts . rest))]
+ [(_ arg)
+ (list (lambda () (arg-contract arg schemeblock0/closeclose)))]
+ [(_ arg . rest)
+ (cons (lambda () (arg-contract arg schemeblock0/close))
+ (arg-contracts . rest))]))
(define-syntax defproc
(syntax-rules ()
[(_ (id arg ...) result desc ...)
(*defproc '[(id arg ...)]
- (list (list (lambda () (arg-contract arg)) ...))
+ (list (arg-contracts arg ...))
(list (lambda () (schemeblock0 result)))
(lambda () (list desc ...)))]))
(define-syntax defproc*
(syntax-rules ()
[(_ [[(id arg ...) result] ...] desc ...)
(*defproc '[(id arg ...) ...]
- (list (list (lambda () (arg-contract arg)) ...) ...)
+ (list (arg-contracts arg ...) ...)
(list (lambda () (schemeblock0 result)) ...)
(lambda () (list desc ...)))]))
(define-syntax defstruct
@@ -282,20 +315,7 @@
3
2))))]
[to-flow (lambda (e)
- (make-flow (list (make-paragraph (list e)))))]
- [arg->elem (lambda (v)
- (cond
- [(pair? v)
- (if (keyword? (car v))
- (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]))])
+ (make-flow (list (make-paragraph (list e)))))])
(parameterize ([current-variable-list
(map (lambda (i)
(and (pair? i)
@@ -307,86 +327,97 @@
(cons
(make-table
'boxed
- (apply
+ (apply
append
(map
(lambda (prototype arg-contracts result-contract first?)
- (append
- (list
- (list (make-flow
- (list
- (make-table
- '((valignment top top top top top))
- (list
- (list
- (to-flow
- (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)
- (not (has-optional? (car a))))
- (values req (reverse o-accum) a)
- (loop (cdr a) (cons (car a) o-accum)))))
- (loop (cdr a) (cons (car a) r-accum))))])
- (to-element (append
- (list (if first?
- (make-target-element
- #f
- (list (to-element (car prototype)))
- (register-scheme-definition (car prototype)))
- (to-element (car prototype))))
- (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)))))
- (to-flow spacer)
- (to-flow 'rarr)
- (to-flow spacer)
- (make-flow (list (result-contract))))))))))
- (apply append
- (map (lambda (v arg-contract)
- (cond
- [(pair? v)
- (list
- (list
- (make-flow
- (list
- (make-table
- `((valignment baseline baseline baseline baseline
- baseline baseline
- ,@(if (has-optional? v)
- '(baseline baseline baseline baseline)
- null)))
- (list
- (let ([v (if (keyword? (car v))
- (cdr v)
- v)])
- (append
+ (let ([name (if first?
+ (make-target-element
+ #f
+ (list (to-element (car prototype)))
+ (register-scheme-definition (car prototype)))
+ (to-element (car prototype)))])
+ (list
+ (list
+ (make-flow
+ (list
+ (if (null? (cdr prototype))
+ (make-table
+ #f
+ (list (list
+ (make-flow
+ (list
+ (make-paragraph
+ (list (schemeparenfont "(")
+ name
+ (schemeparenfont ")"))))))))
+ (make-table
+ #f
+ (let loop ([args (cdr prototype)]
+ [arg-contracts arg-contracts]
+ [first? #t])
+ (let* ([a (car args)]
+ [v (if (keyword? (car a))
+ (cdr a)
+ a)]
+ [dots (and (pair? (cdr args))
+ (not (pair? (cadr args)))
+ (cadr args))])
+ (cons
+ (list (if first?
+ (make-flow
+ (list
+ (make-paragraph
+ (list
+ (schemeparenfont "(")
+ name
+ spacer))))
+ (to-flow spacer))
+ (make-flow
+ (list
+ (make-table
+ '((valignment baseline baseline baseline))
+ (list
(list
- (to-flow (hspace 2))
- (to-flow (arg->elem v))
+ (make-flow
+ (list
+ (make-paragraph
+ (append
+ (list (schemeparenfont "("))
+ (if (keyword? (car a))
+ (list (to-element (car a)) spacer)
+ null)
+ (list (schemefont " "))
+ (if (has-optional? a)
+ (list (schemeparenfont "["))
+ null)
+ (list (to-element (car v)))
+ (if (has-optional? a)
+ (list spacer
+ (to-element (caddr v))
+ (schemeparenfont "]"))
+ null)))))
(to-flow spacer)
- (to-flow ":")
- (to-flow spacer)
- (make-flow (list (arg-contract))))
- (if (has-optional? v)
- (list (to-flow spacer)
- (to-flow "=")
- (to-flow spacer)
- (to-flow (to-element (caddr v))))
- null)))))))))]
- [else null]))
- (cdr prototype)
- arg-contracts))))
+ (make-flow
+ ;; Note: arg-contract includes closing paren for arg,
+ ;; as well as dots or closing paren for arg sequence
+ (list ((car arg-contracts))))))))))
+ (let ([next (if dots
+ (cddr args)
+ (cdr args))])
+ (if (null? next)
+ null
+ (loop next
+ ((if dots cddr cdr) arg-contracts)
+ #f)))))))))))
+ (list
+ (make-flow
+ (list
+ (make-table
+ #f
+ (list (list (to-flow spacer)
+ (to-flow spacer)
+ (make-flow (list (result-contract))))))))))))
prototypes
arg-contractss
result-contracts
@@ -465,8 +496,11 @@
(list (make-target-element
#f
(list (to-element name))
- (register-scheme-definition name))
- spacer ":" spacer
+ (register-scheme-definition name)))))))
+ (list (make-flow
+ (list
+ (make-paragraph
+ (list spacer spacer
(to-element result-contract))))))))
(content-thunk))))
diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss
index dcc06625..96546c63 100644
--- a/collects/scribble/scheme.ss
+++ b/collects/scribble/scheme.ss
@@ -44,7 +44,7 @@
(define-struct (sized-element element) (length))
- (define (typeset c multi-line? prefix1 prefix color?)
+ (define (typeset c multi-line? prefix1 prefix suffix color?)
(let* ([c (syntax-ize c 0)]
[content null]
[docs null]
@@ -146,7 +146,7 @@
(if val? value-color #f)
(list
(make-element (if val? value-color paren-color) '(". "))
- (typeset a #f "" "" (not val?))
+ (typeset a #f "" "" "" (not val?))
(make-element (if val? value-color paren-color) '(" .")))
(+ (syntax-span a) 4)))
(list (syntax-source a)
@@ -389,6 +389,7 @@
(set! dest-col 0)
(hash-table-put! next-col-map init-col dest-col)
((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0) c)
+ (out suffix #f)
(unless (null? content)
(finish-line!))
(if multi-line?
@@ -396,16 +397,16 @@
(make-sized-element #f (reverse content) dest-col))))
(define (to-element c)
- (typeset c #f "" "" #t))
+ (typeset c #f "" "" "" #t))
(define (to-element/no-color c)
- (typeset c #f "" "" #f))
+ (typeset c #f "" "" "" #f))
(define (to-paragraph c)
- (typeset c #t "" "" #t))
+ (typeset c #t "" "" "" #t))
- (define ((to-paragraph/prefix pfx1 pfx) c)
- (typeset c #t pfx1 pfx #t))
+ (define ((to-paragraph/prefix pfx1 pfx sfx) c)
+ (typeset c #t pfx1 pfx sfx #t))
(define-syntax (define-code stx)
(syntax-case stx ()