suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix `defstruct' to use more long-name layout options

Browse Source
This commit is contained in:
Matthew Flatt 2011-08-05 10:01:52 -06:00
parent ad7fddf878
commit f7fd274e80
1 changed files with 68 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/scribble/private/manual-proc.rkt
View File

@ -626,11 +626,12 @@
(cadr name) (cadr name)
(cadr (syntax-e stx-id)))))) (cadr (syntax-e stx-id))))))
just-name))] just-name))]
[sym-length (lambda (s)
(string-length (symbol->string s)))]
[short-width [short-width
(apply + (length fields) 8 (apply + (length fields) 8
(append (append
(map (lambda (s) (map sym-length
(string-length (symbol->string s)))
(append (if (pair? name) name (list name)) (append (if (pair? name) name (list name))
(map field-name fields))) (map field-name fields)))
(map (lambda (f) (map (lambda (f)
@ -656,7 +657,19 @@
(lambda (c) (lambda (c)
(if one-right-column? (if one-right-column?
(list flow-spacer flow-spacer c) (list flow-spacer flow-spacer c)
(list flow-spacer flow-spacer c 'cont 'cont)))]) (list flow-spacer flow-spacer c 'cont 'cont)))]
[split-field-line?
(max-proto-width . < . (+ 8
(if (pair? name)
(+ (sym-length (car name))
1
(sym-length (cadr name)))
(sym-length name))
1
(if (pair? fields)
(sym-length (field-name (car fields)))
0)
1))])
(make-table (make-table
(if one-right-column? (if one-right-column?
#f #f
@ -687,10 +700,29 @@
(not cname-id)) (not cname-id))
(list (racketparenfont ")")) (list (racketparenfont ")"))
null))))) null)))))
(list (to-flow (make-element 'no-break the-name)) (if split-field-line?
(to-flow (make-element (list (to-flow (make-element 'no-break the-name))
#f (list spacer (racketparenfont "(")))) 'cont
(to-flow (make-element 'no-break (to-element (field-view (car fields))))))))) 'cont)
(list (to-flow (make-element 'no-break the-name))
(to-flow (make-element
#f (list spacer (racketparenfont "("))))
(to-flow (make-element 'no-break
(let ([f (to-element (field-view (car fields)))])
(if (null? (cdr fields))
(list f (racketparenfont ")"))
f)))))))))
(if split-field-line?
(list
(list flow-spacer flow-spacer flow-spacer
(to-flow (make-element
#f (list spacer (racketparenfont "("))))
(to-flow (make-element 'no-break
(let ([f (to-element (field-view (car fields)))])
(if (null? (cdr fields))
(list f (racketparenfont ")"))
f))))))
null)
(if (short-width . < . max-proto-width) (if (short-width . < . max-proto-width)
null null
(let loop ([fields (if (null? fields) (let loop ([fields (if (null? fields)
@ -715,19 +747,35 @@
e))))) e)))))
(loop (cdr fields)))))) (loop (cdr fields))))))
(if cname-id (if cname-id
(list (a-right-column (let ([kw (to-element (if extra-cname?
(to-flow (make-element '#:extra-constructor-name
#f '#:constructor-name))]
(append [nm (to-element cname-id)]
(list (to-element (if extra-cname? [close? (and immutable?
'#:extra-constructor-name (not transparent?))])
'#:constructor-name)) (if (max-proto-width . < . (+ 8 ; "(struct "
(hspace 1) 1 ; space between kw & name
(to-element cname-id)) (element-width kw)
(if (and immutable? (element-width nm)
(not transparent?)) (if close? 1 0)))
(list (racketparenfont ")")) ;; use two lines
null)))))) (list (a-right-column (to-flow kw))
(a-right-column
(to-flow
(if close?
(make-element #f (list nm (racketparenfont ")")))
nm))))
;; use one line
(list (a-right-column
(to-flow (make-element
#f
(append
(list kw
(hspace 1)
nm)
(if close?
(list (racketparenfont ")"))
null))))))))
null) null)
(cond (cond
[(and (not immutable?) transparent?) [(and (not immutable?) transparent?)