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

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

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

70
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)))))
(if split-field-line?
(list (to-flow (make-element 'no-break the-name))
'cont
'cont)
(list (to-flow (make-element 'no-break the-name)) (list (to-flow (make-element 'no-break the-name))
(to-flow (make-element (to-flow (make-element
#f (list spacer (racketparenfont "(")))) #f (list spacer (racketparenfont "("))))
(to-flow (make-element 'no-break (to-element (field-view (car fields))))))))) (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
(let ([kw (to-element (if extra-cname?
'#:extra-constructor-name
'#:constructor-name))]
[nm (to-element cname-id)]
[close? (and immutable?
(not transparent?))])
(if (max-proto-width . < . (+ 8 ; "(struct "
1 ; space between kw & name
(element-width kw)
(element-width nm)
(if close? 1 0)))
;; use two lines
(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 (list (a-right-column
(to-flow (make-element (to-flow (make-element
#f #f
(append (append
(list (to-element (if extra-cname? (list kw
'#:extra-constructor-name
'#:constructor-name))
(hspace 1) (hspace 1)
(to-element cname-id)) nm)
(if (and immutable? (if close?
(not transparent?))
(list (racketparenfont ")")) (list (racketparenfont ")"))
null)))))) null))))))))
null) null)
(cond (cond
[(and (not immutable?) transparent?) [(and (not immutable?) transparent?)