commit c0977693653783915a6af3938255190d958d96f5
parent 4939c9cff0812d832311f9f1e68fcf542b0934be
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 27 Jun 2007 00:17:04 +0000
start on regexp functions; further formatting improvements for defproc
svn: r6745
original commit: bf717526b0d76546793db9a52863547fbb030706
Diffstat:
3 files changed, 158 insertions(+), 87 deletions(-)
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -393,20 +393,21 @@
[(eq? v '...)
dots0]
[else v]))]
- [prototype-size (lambda (s)
- (let loop ([s s])
+ [prototype-size (lambda (s first-combine next-combine)
+ (let loop ([s s][combine first-combine])
(if (null? s)
- 1
- (+ 1 (loop (cdr s))
- (cond
- [(symbol? (car s)) (string-length (symbol->string (car s)))]
- [(pair? (car s))
- (if (keyword? (caar s))
- (+ (string-length (keyword->string (caar s)))
- 3
- (string-length (symbol->string (cadar s))))
- (string-length (symbol->string (caar s))))]
- [else 0])))))])
+ 0
+ (combine
+ (loop (cdr s) next-combine)
+ (cond
+ [(symbol? (car s)) (string-length (symbol->string (car s)))]
+ [(pair? (car s))
+ (if (keyword? (caar s))
+ (+ (string-length (keyword->string (caar s)))
+ 3
+ (string-length (symbol->string (cadar s))))
+ (string-length (symbol->string (caar s))))]
+ [else 0])))))])
(parameterize ([current-variable-list
(map (lambda (i)
(and (pair? i)
@@ -422,34 +423,41 @@
append
(map
(lambda (stx-id prototype arg-contracts result-contract first?)
- (append
- (list
- (list (make-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))))]
- [(tagged) (if first?
- (make-target-element
- #f
- (list (to-element (make-just-context (car prototype)
- stx-id)))
- (register-scheme-definition stx-id))
- (to-element (make-just-context (car prototype)
- stx-id)))]
- [(short?) (or ((prototype-size prototype) . < . 40)
- ((length prototype) . < . 3))]
- [(end) (list (to-flow spacer)
- (to-flow 'rarr)
- (to-flow spacer)
- (make-flow (list (result-contract))))])
+ (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))))]
+ [(tagged) (if first?
+ (make-target-element
+ #f
+ (list (to-element (make-just-context (car prototype)
+ stx-id)))
+ (register-scheme-definition stx-id))
+ (to-element (make-just-context (car prototype)
+ stx-id)))]
+ [(flat-size) (prototype-size prototype + +)]
+ [(short?) (or (flat-size . < . 40)
+ ((length prototype) . < . 3))]
+ [(res) (result-contract)]
+ [(result-next-line?) ((+ (if short?
+ flat-size
+ (prototype-size prototype + max))
+ (flow-element-width res))
+ . >= . 50)]
+ [(end) (list (to-flow spacer)
+ (to-flow 'rarr)
+ (to-flow spacer)
+ (make-flow (list res)))])
+ (append
+ (list
+ (list (make-flow
(if short?
(make-table-if-necessary
"prototype"
@@ -468,12 +476,16 @@
'paren-shape
#\?))))
(map arg->elem more-required))))
- end)))
+ (if result-next-line?
+ null
+ end))))
(let ([not-end
- (list (to-flow spacer)
- (to-flow spacer)
- (to-flow spacer)
- (to-flow spacer))])
+ (if result-next-line?
+ (list (to-flow spacer))
+ (list (to-flow spacer)
+ (to-flow spacer)
+ (to-flow spacer)
+ (to-flow spacer)))])
(list
(make-table
"prototype"
@@ -513,40 +525,46 @@
#f
(list a "]" (schemeparenfont ")"))))]
[else a])))
- (if (null? (cdr args))
+ (if (and (null? (cdr args))
+ (not result-next-line?))
end
not-end))
- (loop (cdr args) (sub1 req))))))))))))))
- (apply append
- (map (lambda (v arg-contract)
- (cond
- [(pair? v)
- (list
- (list
- (make-flow
- (make-table-if-necessary
- "argcontract"
- (list
- (let ([v (if (keyword? (car v))
- (cdr v)
- v)])
- (append
- (list
- (to-flow (hspace 2))
- (to-flow (arg->elem v))
- (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))))
+ (loop (cdr args) (sub1 req)))))))))))))
+ (if result-next-line?
+ (list (list (make-flow (make-table-if-necessary
+ "prototype"
+ (list end)))))
+ null)
+ (apply append
+ (map (lambda (v arg-contract)
+ (cond
+ [(pair? v)
+ (list
+ (list
+ (make-flow
+ (make-table-if-necessary
+ "argcontract"
+ (list
+ (let ([v (if (keyword? (car v))
+ (cdr v)
+ v)])
+ (append
+ (list
+ (to-flow (hspace 2))
+ (to-flow (arg->elem v))
+ (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)))))
stx-ids
prototypes
arg-contractss
diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss
@@ -372,7 +372,8 @@
(make-link-element "schemesyntaxlink" (list s) stag)]
[vd
(make-link-element "schemevaluelink" (list s) vtag)]
- [else s])))))
+ [else s]))))
+ (lambda () s))
(literalize-spaces s))
(cond
[(positive? quote-depth) value-color]
diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss
@@ -95,28 +95,33 @@
delayed-element-ref
delayed-element-set!)
(make-struct-type 'delayed-element #f
- 1 1 #f
+ 2 1 #f
(list (cons prop:serializable
(make-serialize-info
(lambda (d)
- (unless (delayed-element-ref d 1)
+ (unless (delayed-element-ref d 2)
(error 'serialize-delayed-element
"cannot serialize a delayed element that was not resolved: ~e"
d))
- (vector (delayed-element-ref d 1)))
+ (vector (delayed-element-ref d 2)))
#'deserialize-delayed-element
#f
(or (current-load-relative-directory) (current-directory)))))))
(define-syntax delayed-element (list-immutable #'struct:delayed-element
#'make-delayed-element
#'delayed-element?
- (list-immutable #'delayed-element-render)
- (list-immutable #'set-delayed-element-render!)
+ (list-immutable #'delayed-element-sizer
+ #'delayed-element-render)
+ (list-immutable #'set-delayed-element-sizer!
+ #'set-delayed-element-render!)
#t))
(define delayed-element-render (make-struct-field-accessor delayed-element-ref 0))
+ (define delayed-element-sizer (make-struct-field-accessor delayed-element-ref 1))
(define set-delayed-element-render! (make-struct-field-mutator delayed-element-set! 0))
+ (define set-delayed-element-sizer! (make-struct-field-mutator delayed-element-set! 1))
(provide/contract
- (struct delayed-element ([render (any/c part? any/c . -> . list?)])))
+ (struct delayed-element ([render (any/c part? any/c . -> . list?)]
+ [sizer (-> any)])))
(provide deserialize-delayed-element)
(define deserialize-delayed-element
@@ -124,9 +129,9 @@
(provide force-delayed-element)
(define (force-delayed-element d renderer sec ht)
- (or (delayed-element-ref d 1)
+ (or (delayed-element-ref d 2)
(let ([v ((delayed-element-ref d 0) renderer sec ht)])
- (delayed-element-set! d 1 v)
+ (delayed-element-set! d 2 v)
v)))
;; ----------------------------------------
@@ -163,5 +168,52 @@
renderer sec ht)]
[else (element->string c)])]))
+ ;; ----------------------------------------
+
+ (provide flow-element-width
+ element-width)
+
+ (define (element-width s)
+ (cond
+ [(string? s) (string-length s)]
+ [(element? s) (apply + (map element-width (element-content s)))]
+ [(delayed-element? s) (element-width ((delayed-element-sizer s)))]
+ [else 1]))
+
+ (define (paragraph-width s)
+ (apply + (map element-width (paragraph-content s))))
+
+ (define (flow-width f)
+ (apply max 0 (map flow-element-width (flow-paragraphs f))))
+
+ (define (flow-element-width p)
+ (cond
+ [(paragraph? p) (paragraph-width p)]
+ [(table? p) (table-width p)]
+ [(itemization? p) (itemization-width p)]
+ [(blockquote? p) (blockquote-width p)]
+ [(delayed-flow-element? p) 1]))
+
+ (define (table-width p)
+ (let ([flowss (table-flowss p)])
+ (if (null? flowss)
+ 0
+ (let loop ([flowss flowss])
+ (if (null? (car flowss))
+ 0
+ (+ (apply max
+ 0
+ (map flow-width
+ (map car flowss)))
+ (loop (map cdr flowss))))))))
+
+ (define (itemization-width p)
+ (apply max 0 (map flow-width (itemization-flows p))))
+
+ (define (blockquote-width p)
+ (+ 4 (apply max 0 (map paragraph-width (blockquote-paragraphs p)))))
+
+ ;; ----------------------------------------
+
)
