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

scribble/manual: improve defstruct layout

Browse Source 
The old layout used column spans that created ugly space around parentheses
for some combinations of field-name and keyword-modifier lengths. The new
layot avoids the problem by breaking the keyword modifiers into their
own table.

original commit: a391556faa2d2b43f39b2d48a139085704a865ec
This commit is contained in:
Matthew Flatt 2014-01-15 09:03:40 -07:00
parent 1665fec8c2
commit ca59988ba0
1 changed files with 136 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

268
pkgs/scribble-pkgs/scribble-lib/scribble/private/manual-proc.rkt
View File

@ -732,13 +732,18 @@
(string->symbol (format "make-~a" (syntax-e name-id))) (string->symbol (format "make-~a" (syntax-e name-id)))
name-id name-id
name-id))])) name-id))]))
(define keyword-modifiers? (or (not immutable?)
transparent?
cname-id))
(define keyword-spacer (hspace 4)) ; 2 would match DrRacket indentation, but 4 looks better with field contracts after
(define main-table (define main-table
(make-table (make-table
boxed-style boxed-style
(cons (append
(list ;; First line in "boxed" table is struct name and fields:
((add-background-label "struct") (list
(make-flow (list
((add-background-label "struct")
(list (list
(let* ([the-name (let* ([the-name
(let ([just-name (let ([just-name
@ -796,7 +801,9 @@
[sym-length (lambda (s) [sym-length (lambda (s)
(string-length (symbol->string s)))] (string-length (symbol->string s)))]
[short-width [short-width
(apply + (length fields) 8 (apply +
(length fields) ; spaces between field names
8 ; "struct" + "(" + ")"
(append (append
(map sym-length (map sym-length
(append (if (pair? name) name (list name)) (append (if (pair? name) name (list name))
@ -808,24 +815,21 @@
0)) 0))
fields)))]) fields)))])
(if (and (short-width . < . max-proto-width) (if (and (short-width . < . max-proto-width)
immutable? (not keyword-modifiers?))
(not transparent?) ;; All on one line:
(not cname-id))
(make-omitable-paragraph (make-omitable-paragraph
(list (list
(to-element (to-element
`(,(racket struct) `(,(racket struct)
,the-name ,the-name
,(map field-view fields))))) ,(map field-view fields)))))
;; Multi-line view (leaving out last paren if keywords follow):
(let* ([one-right-column? (let* ([one-right-column?
;; Does the struct name and fields fit on a single line?
(or (null? fields) (or (null? fields)
(short-width . < . max-proto-width))] (short-width . < . max-proto-width))]
[a-right-column
(lambda (c)
(if one-right-column?
(list flow-spacer flow-spacer c)
(list flow-spacer flow-spacer c 'cont 'cont)))]
[split-field-line? [split-field-line?
;; start fields on the line after "struct"?
(max-proto-width . < . (+ 8 (max-proto-width . < . (+ 8
(if (pair? name) (if (pair? name)
(+ (sym-length (car name)) (+ (sym-length (car name))
@ -838,15 +842,12 @@
0) 0)
1))]) 1))])
(make-table (make-table
(if one-right-column? #f
#f ;; First four columns: "(struct" <space> <name><space> (
;; Shift all extra width to last column: ;; If all fields on the first line, extra columns follow;
(make-style #f (list ;; If only first field on same line, filds are in fourth column
(make-table-columns ;; If no field is on the first line, no fourth column after all
(for/list ([i 5]) ;; and fields are in the second column
(if (i . < . 4)
(make-style #f (list (column-attributes '((width . "0*")))))
(make-style #f null)))))))
(append (append
(list (list
(append (append
@ -856,135 +857,138 @@
(racket struct)))) (racket struct))))
flow-spacer) flow-spacer)
(if one-right-column? (if one-right-column?
(list (to-flow (make-element ;; struct name and fields on one line:
#f (list (to-flow (list the-name
(list* the-name spacer
spacer (to-element (map field-view
(to-element (map field-view fields))
fields)) (if (and immutable?
(if (and immutable? (not transparent?)
(not transparent?) (not cname-id))
(not cname-id)) (racketparenfont ")")
(list (racketparenfont ")")) null))))
null)))))
(if split-field-line? (if split-field-line?
(list (to-flow (make-element 'no-break the-name)) ;; Field start on line after "struct":
'cont (list (to-flow (make-element 'no-break the-name)))
'cont) ;; First field on the same line as "struct":
(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-flow (make-element 'no-break
(let ([f (to-element (field-view (car fields)))]) (let ([f (to-element (field-view (car fields)))])
(if (null? (cdr fields)) (if (null? (cdr fields))
(list f (racketparenfont ")")) (list f (racketparenfont ")"))
f))))))))) f)))))))))
(if split-field-line? (if split-field-line?
;; First field, which starts on the next line:
(list (list
(list flow-spacer flow-spacer flow-spacer (list flow-spacer flow-spacer
(to-flow (make-element (to-flow (list
#f (list spacer (racketparenfont "(")))) (racketparenfont "(")
(to-flow (make-element 'no-break (make-element 'no-break
(let ([f (to-element (field-view (car fields)))]) (let ([f (to-element (field-view (car fields)))])
(if (null? (cdr fields)) (if (null? (cdr fields))
(list f (racketparenfont ")")) (list f (racketparenfont ")"))
f)))))) f)))))))
null) null)
(if (short-width . < . max-proto-width) ;; Remaining fields:
(if one-right-column?
null null
(let loop ([fields (if (null? fields) (let loop ([fields (if (null? fields)
fields (cdr fields))]) fields
(cdr fields))])
(if (null? fields) (if (null? fields)
null null
(cons (cons
(let ([fld (car fields)]) (let ([fld (car fields)])
(list flow-spacer flow-spacer (append
flow-spacer flow-spacer (list flow-spacer flow-spacer)
(to-flow (if split-field-line? null (list flow-spacer flow-spacer))
(let ([e (to-element (field-view fld))]) (list (to-flow
(if (null? (cdr fields)) (list
(make-element (if split-field-line? spacer null)
#f (let ([e (to-element (field-view fld))])
(list e (racketparenfont (if (null? (cdr fields))
(if (and immutable? (list e
(not transparent?) (racketparenfont
(not cname-id)) (if (and immutable?
"))" (not transparent?)
")")))) (not cname-id))
e))))) "))"
(loop (cdr fields)))))) ")")))
(if cname-id e)))))))
(let ([kw (to-element (if (if cname-given? (loop (cdr fields)))))))))))))))
extra-cname? ;; Next lines at "boxed" level are construct-name keywords:
default-extra?) (if cname-id
'#:extra-constructor-name (let ([kw (to-element (if (if cname-given?
'#:constructor-name))] extra-cname?
[nm (to-element cname-id)] default-extra?)
[close? (and immutable? '#:extra-constructor-name
(not transparent?))]) '#:constructor-name))]
(if (max-proto-width . < . (+ 8 ; "(struct " [nm (to-element cname-id)]
1 ; space between kw & name [close? (and immutable?
(element-width kw) (not transparent?))])
(element-width nm) (if (max-proto-width . < . (+ (element-width keyword-spacer)
(if close? 1 0))) 1 ; space between kw & name
;; use two lines (element-width kw)
(list (a-right-column (to-flow kw)) (element-width nm)
(a-right-column (if close? 1 0)))
(to-flow ;; use two lines for #:constructor-name
(if close? (list (list (to-flow (list keyword-spacer kw)))
(make-element #f (list nm (racketparenfont ")"))) (list (to-flow
nm)))) (list
;; use one line keyword-spacer
(list (a-right-column (if close?
(to-flow (make-element (make-element #f (list nm (racketparenfont ")")))
#f nm)))))
(append ;; use one line for #:constructor-name
(list kw (list (list
(hspace 1) (to-flow (make-element
nm) #f
(if close? (list
(list (racketparenfont ")")) keyword-spacer
null)))))))) kw (hspace 1) nm
null) (if close?
(cond (racketparenfont ")")
[(and (not immutable?) transparent?) null))))))))
(list null)
(a-right-column (to-flow (to-element '#:mutable))) ;; Next lines at "boxed" level are prefab/transparent/mutable
(a-right-column (to-flow (make-element (cond
#f [(and (not immutable?) transparent?)
(list (if prefab? (list
(to-element '#:prefab) (list (to-flow (list keyword-spacer (to-element '#:mutable))))
(to-element '#:transparent)) (list (to-flow (list keyword-spacer
(racketparenfont ")"))))))] (if prefab?
[(not immutable?) (to-element '#:prefab)
(list (to-element '#:transparent))
(a-right-column (to-flow (make-element (racketparenfont ")")))))]
#f [(not immutable?)
(list (to-element '#:mutable) (list
(racketparenfont ")"))))))] (list (to-flow (list keyword-spacer
[transparent? (to-element '#:mutable)
(list (racketparenfont ")")))))]
(a-right-column (to-flow (make-element [transparent?
#f (list
(list (if prefab? (list (to-flow (list keyword-spacer
(to-element '#:prefab) (if prefab?
(to-element '#:transparent)) (to-element '#:prefab)
(racketparenfont ")"))))))] (to-element '#:transparent))
[else null])))))))))) (racketparenfont ")")))))]
[else null])
;; Remaining lines at "boxed" level are field contracts:
(map (lambda (v field-contract) (map (lambda (v field-contract)
(cond (cond
[(pair? v) [(pair? v)
(list (list
(make-flow (make-table-if-necessary
(make-table-if-necessary "argcontract"
"argcontract" (list (list (to-flow (hspace 2))
(list (list (to-flow (hspace 2)) (to-flow (to-element (field-name v)))
(to-flow (to-element (field-name v))) flow-spacer
flow-spacer (to-flow ":")
(to-flow ":") flow-spacer
flow-spacer (make-flow (list (field-contract)))))))]
(make-flow (list (field-contract))))))))] [else null]))
[else null]))
fields field-contracts)))) fields field-contracts))))
(make-box-splice (make-box-splice
(cons (cons