From 0fd78b8ca828489de2c37638ad4bdd88ad58dc7b Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 24 Mar 2014 18:06:29 -0600
Subject: [PATCH] scribble/base: add `#:{column,row,cell}-properties` arguments
to `tabular`
The new arguments greatly simplify adding properties such as alignment
and (HTML) background colors to table cells. For example, to make a
table with 'right alignment for the left-hand column, 'center alignment
for the second column, and 'left alignment for all remaining columns:
(tabular cells
#:sep (hspace 1)
#:column-properties '(right center left))
Also, make `color-property` and `background-color-property` recognized
as table-cell style properties.
Finally, implement horizontal alignment for text rendering.
original commit: 316fc0dbf5e26061245d815c992cc54d9738aa79
---
.../scribblings/scribble/base.scrbl | 89 ++++++++--
.../scribblings/scribble/core.scrbl | 28 ++-
.../scribble-lib/scribble/base.rkt | 162 +++++++++++++++++-
.../scribble-lib/scribble/html-render.rkt | 5 +-
.../scribble-lib/scribble/text-render.rkt | 39 ++++-
.../tests/scribble/docs/table.scrbl | 20 +++
.../tests/scribble/docs/table.txt | 9 +
7 files changed, 325 insertions(+), 27 deletions(-)
create mode 100644 pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table.scrbl
create mode 100644 pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table.txt
diff --git a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/base.scrbl b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/base.scrbl
index d9d921ba..05345bb7 100644
--- a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/base.scrbl
+++ b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/base.scrbl
@@ -241,23 +241,88 @@ Returns @racket[#t] if @racket[v] is an item produced by
@defproc[(tabular [cells (listof (listof (or/c block? content? 'cont)))]
[#:style style (or/c style? string? symbol? #f) #f]
- [#:sep sep (or/c block? content? #f) #f])
+ [#:sep sep (or/c block? content? #f) #f]
+ [#:column-properties column-properties (listof any/c) '()]
+ [#:row-properties row-properties (listof any/c) '()]
+ [#:cell-properties cell-properties (listof (listof any/c)) '()])
table?]{
-Creates a @tech{table} with the given content, which is supplies as a
-list of rows, where each row has a list of cells. The length of all
-rows must match.
+Creates a @tech{table} with the given @racket[cells] content, which is
+supplied as a list of rows, where each row has a list of cells. The
+length of all rows must match.
-If @racket[sep] is not @racket[#f], it is inserted between every
-column in the table. Otherwise, the default style places no space
-between table columns.
-
-Use @racket['cont] as a cell to continue the content of the preceding
-cell in a row in the space that would otherwise be used for a new
-cell. A @racket['cont] must not appear as the first cell in a row.
+Use @racket['cont] in @racket[cells] as a cell to continue the content
+of the preceding cell in a row in the space that would otherwise be
+used for a new cell. A @racket['cont] must not appear as the first
+cell in a row.
The @racket[style] argument is handled the same as @racket[para].
+If @racket[sep] is not @racket[#f], it is inserted as a new column
+between every column in the table; note that any
+@racket[table-columns] or @racket[table-cells] property in
+@racket[style] must take the added columns into account. Otherwise,
+the default style places no space between table columns.
+
+The @racket[column-properties], @racket[row-properties], and
+@racket[cell-properties] arguments specify @tech{style properties} for
+the columns and cells of a table; see @racket[table-columns] and
+@racket[table-cells] for a description of recognized properties. The
+lists do not contain entries for columns potentially introduced for
+@racket[sep], and when non-empty, they are extended as needed to match
+the table size determined by @racket[cells]:
+
+@itemlist[
+
+ @item{If the length of @racket[column-properties] is less than the
+ length of each row in @racket[cells], the last item of the list
+ is duplicated to make the list long enough.}
+
+ @item{If the length of @racket[row-properties] is less than the
+ length of @racket[cells], the last item of the list is
+ duplicated to make the list long enough.}
+
+ @item{If the length of @racket[cell-properties] is less than the
+ number of rows in @racket[cells], then the last element is
+ duplicated to make the list long enough. Each list within
+ @racket[cell-properties] is treated like a
+ @racket[column-properties] list---expanded as needed to match
+ the number of columns in each row.}
+
+]
+
+Each element of @racket[column-properties] or @racket[row-properties]
+is either a list of @tech{style property} values or a non-list element
+that is wrapped as a list. Similarly, for each list that is an element
+of @racket[cell-properties], the list's non-list elements are wrapped
+as nested lists.
+
+If @racket[column-properties] is non-empty, then its list of property
+lists is converted into a @racket[table-columns] @tech{style property}
+that is added to the style specified by @racket[style]---or merged
+with an existing @racket[table-columns] @tech{style property} that
+matches the column shape of @racket[cells]. In addition, if either
+@racket[row-properties] or @racket[cell-properties] is non-empty, the
+property lists of @racket[column-properties] are merged
+with the property lists of @racket[row-properties] and
+@racket[cell-properties]. If @racket[row-properties] or
+@racket[cell-properties] is non-empty, the merged lists are
+converted into a @racket[table-cells] @tech{style property} that is
+added to the style specified by @racket[style]---or merged with an
+existing @racket[table-cells] @tech{style property} that matches the
+shape of @racket[cells].
+
+@margin-note{If the style lists for @racket[column-properties] are
+both merged with @racket[cell-properties] and converted to
+@racket[table-columns], then @racket[style] will contain some
+redundant information. In that case, @racket[column-attributes]
+properties will be used from @racket[table-columns], while other
+properties will be used from the merger into @racket[table-cells].}
+
+@history[#:changed "1.1" @elem{Added the @racket[#:column-properties],
+ @racket[#:row-properties],
+ and @racket[#:cell-properties] arguments.}]
+
Examples:
@codeblock[#:keep-lang-line? #f]|{
#lang scribble/manual
@@ -266,6 +331,7 @@ Examples:
(list "soup" "tonjiru"))]
@tabular[#:style 'boxed
+ #:column-properties '(left right)
(list (list @bold{recipe} @bold{vegetable})
(list "caldo verde" "kale")
(list "kinpira gobō" "burdock")
@@ -277,6 +343,7 @@ Examples:
(list "soup" "tonjiru"))]
@tabular[#:style 'boxed
+ #:column-properties '(left right)
(list (list @bold{recipe} @bold{vegetable})
(list "caldo verde" "kale")
(list "kinpira gobō" "burdock")
diff --git a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/core.scrbl b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/core.scrbl
index 96d8f34d..4890066a 100644
--- a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/core.scrbl
+++ b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/core.scrbl
@@ -469,7 +469,7 @@ The recognized @tech{style properties} are as follows:
to the part title.}
@item{@racket[background-color-property] structure --- For HTML,
- Applies a color to the background of the part title.}
+ applies a color to the background of the part title.}
@item{@racket[hover-property] structure --- For HTML, adds a text
label to the title to be shown when the mouse hovers over
@@ -588,10 +588,12 @@ The following @tech{style properties} are currently recognized:
@item{@racket[table-columns] structure --- Provides column-specific
styles, but only @racket[column-attributes] properties (if any)
are used if a @racket[table-cells] structure is included as a
- @tech{style property}.}
+ @tech{style property}. See @racket[table-cells] for information
+ about how a column style is used for each cell.}
@item{@racket[table-cells] structure --- Provides cell-specific
- styles.}
+ styles. See @racket[table-cells] for information about how the
+ styles are used.}
@item{@racket[attributes] structure --- Provides additional HTML
attributes for the @tt{<table>} tag.}
@@ -1109,8 +1111,8 @@ renderer, but at the recognized set includes at least
are used as RGB levels.
When rendering to HTML, a @racket[color-property] is also recognized
-for a @tech{block} or @racket[part] (and used for the title in the
-latter case).}
+for a @tech{block}, @racket[part] (and used for the title in the
+latter case)or cell in a @racket[table].}
@defstruct[background-color-property ([color (or/c string? (list/c byte? byte? byte?))])]{
@@ -1126,7 +1128,7 @@ styles.
If a cell style has a string name, it is used as an HTML class for the
@tt{<td>} tag or as a Latex command name.
-The following symbols are recognized as cell-@tech{style properties}:
+The following are recognized as cell-@tech{style properties}:
@itemize[
@@ -1144,11 +1146,19 @@ The following symbols are recognized as cell-@tech{style properties}:
@item{@racket['vcenter] --- Center the cell content vertically.}
+ @item{@racket[color-property] structure --- For HTML, applies a color
+ to the cell content.}
+
+ @item{@racket[background-color-property] structure --- For HTML,
+ applies a color to the background of the cell.}
+
+ @item{@racket[attributes] --- Provides additional HTML attributes
+ for the cell's @tt{<td>} tag.}
+
]
-In addition, for HTML output, @racket[attributes] structures as
-@tech{style properties} can add arbitrary attributes to a cell's
-@tt{<td>} tag.}
+@history[#:changed "1.1" @elem{Added @racket[color-property] and
+ @racket[background-color-property] support.}]}
@defstruct[table-columns ([styles (listof style?)])]{
diff --git a/pkgs/scribble-pkgs/scribble-lib/scribble/base.rkt b/pkgs/scribble-pkgs/scribble-lib/scribble/base.rkt
index 61fbb4e6..3b1f1547 100644
--- a/pkgs/scribble-pkgs/scribble-lib/scribble/base.rkt
+++ b/pkgs/scribble-pkgs/scribble-lib/scribble/base.rkt
@@ -324,6 +324,13 @@
;; ----------------------------------------
+(define (cell-spec/c c)
+ (define rc
+ (recursive-contract (or/c c
+ empty
+ (cons/c rc rc))))
+ rc)
+
(provide/contract
[para (->* ()
(#:style (or/c style? string? symbol? #f ))
@@ -339,7 +346,10 @@
compound-paragraph?)]
[tabular (->* ((listof (listof (or/c 'cont block? content?))))
(#:style (or/c style? string? symbol? #f)
- #:sep (or/c content? block? #f))
+ #:sep (or/c content? block? #f)
+ #:column-properties (listof any/c)
+ #:row-properties (listof any/c)
+ #:cell-properties (listof (listof any/c)))
table?)])
(define (convert-block-style style)
@@ -360,7 +370,12 @@
(make-compound-paragraph (convert-block-style style)
(decode-flow c)))
-(define (tabular #:style [style #f] #:sep [sep #f] cells)
+(define (tabular #:style [style #f]
+ #:sep [sep #f]
+ #:column-properties [column-properties null]
+ #:row-properties [row-properties null]
+ #:cell-properties [cell-properties null]
+ cells)
(define (nth-str pos)
(case (modulo pos 10)
[(1) "st"]
@@ -387,7 +402,148 @@
'tabular
(format "~a~a row starts with 'cont: " pos (nth-str pos))
row)))
- (make-table (convert-block-style style)
+ (make-table (let ([s (convert-block-style style)])
+ (define n-orig-cols (if (null? cells)
+ 0
+ (length (car cells))))
+ (define n-cols (if sep
+ (max 0 (sub1 (* n-orig-cols 2)))
+ n-orig-cols))
+ (define n-rows (length cells))
+ (unless (null? cells)
+ (when ((length column-properties) . > . n-orig-cols)
+ (raise-mismatch-error
+ 'tabular
+ "column properties list is too long: "
+ column-properties)))
+ (when ((length row-properties) . > . n-rows)
+ (raise-mismatch-error
+ 'tabular
+ "row properties list is too long: "
+ row-properties))
+ (when ((length cell-properties) . > . n-rows)
+ (raise-mismatch-error
+ 'tabular
+ "cell properties list is too long: "
+ cell-properties))
+ (unless (null? cells)
+ (for ([row (in-list cell-properties)])
+ (when ((length row) . > . n-orig-cols)
+ (raise-mismatch-error
+ 'tabular
+ "row list within cell properties list is too long: "
+ row))))
+ ;; Expand given column and cell properties lists to match
+ ;; the dimensions of the given `cells` by duplicating
+ ;; the last element of a list as needed (and ignoring
+ ;; extra elements):
+ (define (make-full-column-properties column-properties)
+ (let loop ([column-properties column-properties]
+ [n 0]
+ [prev null])
+ (cond
+ [(= n n-cols) null]
+ [(null? column-properties)
+ (if (or (zero? n) (not sep))
+ (cons prev (loop null (add1 n) prev))
+ (list* prev prev (loop null (+ n 2) prev)))]
+ [else
+ (define (to-list v) (if (list? v) v (list v)))
+ (define props (to-list (car column-properties)))
+ (define rest (loop (cdr column-properties)
+ (if (or (zero? n) (not sep))
+ (add1 n)
+ (+ n 2))
+ props))
+ (if (or (zero? n) (not sep))
+ (cons props rest)
+ (list* null props rest))])))
+ (define full-column-properties
+ (make-full-column-properties column-properties))
+ (define (make-full-cell-properties cell-properties)
+ (let loop ([cell-properties cell-properties]
+ [n 0]
+ [prev (make-list n-cols null)])
+ (cond
+ [(= n n-rows) null]
+ [(null? cell-properties)
+ (cons prev (loop null (add1 n) prev))]
+ [else
+ (define props (make-full-column-properties (car cell-properties)))
+ (cons props
+ (loop (cdr cell-properties)
+ (add1 n)
+ props))])))
+ (define full-cell-properties
+ (for/list ([c-row (in-list (make-full-cell-properties cell-properties))]
+ [r-row (in-list (make-full-cell-properties (map list row-properties)))])
+ (for/list ([c (in-list c-row)]
+ [r (in-list r-row)])
+ (append c r))))
+ (define all-cell-properties
+ (and (or (pair? row-properties)
+ (pair? cell-properties))
+ (if (null? column-properties)
+ full-cell-properties
+ (for/list ([row (in-list full-cell-properties)])
+ (for/list ([cell (in-list row)]
+ [col (in-list full-column-properties)])
+ (append cell col))))))
+ (define all-column-properties
+ (and (pair? column-properties)
+ full-column-properties))
+ ;; Will werge `cell-properties` and `column-properties` into
+ ;; `s`. Start by finding any existing `table-columns`
+ ;; and `table-cells` properties with the right number of
+ ;; styles:
+ (define props (style-properties s))
+ (define tc (and all-column-properties
+ (let ([tc (ormap (lambda (v) (and (table-columns? v) v))
+ props)])
+ (if (and tc
+ (= (length (table-columns-styles tc))
+ n-cols))
+ tc
+ #f))))
+ (define tl (and all-cell-properties
+ (let ([tl (ormap (lambda (v) (and (table-cells? v) v))
+ props)])
+ (if (and tl
+ (= (length (table-cells-styless tl))
+ n-rows)
+ (andmap (lambda (cl)
+ (= (length cl) n-cols))
+ (table-cells-styless tl)))
+ tl
+ #f))))
+ ;; Merge:
+ (define (cons-maybe v l) (if v (cons v l) l))
+ (make-style (style-name s)
+ (cons-maybe
+ (and all-column-properties
+ (table-columns
+ (if tc
+ (for/list ([ps (in-list all-column-properties)]
+ [cs (in-list (table-columns-styles tc))])
+ (make-style (style-name cs)
+ (append ps (style-properties cs))))
+ (for/list ([ps (in-list all-column-properties)])
+ (make-style #f ps)))))
+ (cons-maybe
+ (and all-cell-properties
+ (table-cells
+ (if tl
+ (for/list ([pss (in-list all-cell-properties)]
+ [css (in-list (table-cells-styless tl))])
+ (for/list ([ps (in-list pss)]
+ [cs (in-list css)])
+ (make-style (style-name cs)
+ (append ps (style-properties cs)))))
+ (for/list ([pss (in-list all-cell-properties)])
+ (for/list ([ps (in-list pss)])
+ (make-style #f ps))))))
+ (remq tc (remq tl props))))))
+ ;; Process cells:
(map (lambda (row)
(define (cvt cell)
(cond
diff --git a/pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt b/pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt
index d3ebebd3..10125a66 100644
--- a/pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt
+++ b/pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt
@@ -1490,7 +1490,10 @@
(pair? (style-properties column-style)))
(style->attribs (make-style
#f
- (filter attributes?
+ (filter (lambda (a)
+ (or (attributes? a)
+ (color-property? a)
+ (background-color-property? a)))
(style-properties column-style))))
null)
,@(if (and (pair? (cdr ds))
diff --git a/pkgs/scribble-pkgs/scribble-lib/scribble/text-render.rkt b/pkgs/scribble-pkgs/scribble-lib/scribble/text-render.rkt
index d8484b80..e297b25c 100644
--- a/pkgs/scribble-pkgs/scribble-lib/scribble/text-render.rkt
+++ b/pkgs/scribble-pkgs/scribble-lib/scribble/text-render.rkt
@@ -88,6 +88,31 @@
(regexp-replace #rx"\n$" (get-output-string o) "")))))
flows))
flowss)]
+ [alignss
+ (cond
+ [(ormap (lambda (v) (and (table-cells? v) v)) (style-properties (table-style i)))
+ => (lambda (tc)
+ (for/list ([l (in-list (table-cells-styless tc))])
+ (for/list ([s (in-list l)])
+ (define p (style-properties s))
+ (cond
+ [(member 'right p) 'right]
+ [(member 'center p) 'center]
+ [else 'left]))))]
+ [(ormap (lambda (v) (and (table-columns? v) v)) (style-properties (table-style i)))
+ => (lambda (tc)
+ (make-list
+ (length flowss)
+ (for/list ([s (in-list (table-columns-styles tc))])
+ (define p (style-properties s))
+ (cond
+ [(member 'right p) 'right]
+ [(member 'center p) 'center]
+ [else 'left]))))]
+ [else
+ (if (null? flowss)
+ null
+ (make-list (length flowss) (make-list (length (car flowss)) 'left)))])]
[widths (map (lambda (col)
(for/fold ([d 0]) ([i (in-list col)])
(if (eq? i 'cont)
@@ -95,7 +120,8 @@
(apply max d (map string-length i)))))
(apply map list strs))]
[x-length (lambda (col) (if (eq? col 'cont) 0 (length col)))])
- (for/fold ([indent? #f]) ([row (in-list strs)])
+ (for/fold ([indent? #f]) ([row (in-list strs)]
+ [aligns (in-list alignss)])
(let ([h (apply max 0 (map x-length row))])
(let ([row* (for/list ([i (in-range h)])
(for/list ([col (in-list row)])
@@ -106,11 +132,18 @@
(when indent? (indent))
(for/fold ([space? #f])
([col (in-list sub-row)]
- [w (in-list widths)])
+ [w (in-list widths)]
+ [align (in-list aligns)])
;; (when space? (display " "))
(let ([col (if (eq? col 'cont) "" col)])
+ (define gap (max 0 (- w (string-length col))))
+ (case align
+ [(right) (display (make-string gap #\space))]
+ [(center) (display (make-string (quotient gap 2) #\space))])
(display col)
- (display (make-string (max 0 (- w (string-length col))) #\space)))
+ (case align
+ [(left) (display (make-string gap #\space))]
+ [(center) (display (make-string (- gap (quotient gap 2)) #\space))]))
#t)
(newline)
#t)))
diff --git a/pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table.scrbl b/pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table.scrbl
new file mode 100644
index 00000000..392c97bb
--- /dev/null
+++ b/pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table.scrbl
@@ -0,0 +1,20 @@
+#lang scribble/manual
+
+@(tabular #:column-properties (list 'left 'center 'right)
+ #:sep "-"
+ (list (list "A" "B" "C" "D")
+ (list "apple" "banana" "coconut" "donut")))
+
+
+@(tabular #:cell-properties (list (list 'right 'center 'left)
+ (list))
+ #:sep "-"
+ (list (list "A" "B" "C" "D")
+ (list "apple" "banana" "coconut" "donut")
+ (list "a" "b" "c" "d")))
+
+@(tabular #:column-properties (list '() '() 'left)
+ #:cell-properties (list (list 'right 'center '()))
+ #:sep "-"
+ (list (list "A" "B" "C" "D")
+ (list "apple" "banana" "coconut" "donut")))
diff --git a/pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table.txt b/pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table.txt
new file mode 100644
index 00000000..c907d34e
--- /dev/null
+++ b/pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table.txt
@@ -0,0 +1,9 @@
+A - B - C- D
+apple-banana-coconut-donut
+
+ A- B -C -D
+apple-banana-coconut-donut
+a -b -c -d
+
+ A- B -C -D
+apple-banana-coconut-donut