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

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
+Creates a @tech{table} with the given @racket[cells] content, which is
-list of rows, where each row has a list of cells. The length of all
+supplied as a list of rows, where each row has a list of cells. The
-rows must match.
+length of all rows must match.
 
-If @racket[sep] is not @racket[#f], it is inserted between every
+Use @racket['cont] in @racket[cells] as a cell to continue the content
-column in the table. Otherwise, the default style places no space
+of the preceding cell in a row in the space that would otherwise be
-between table columns.
+used for a new cell. A @racket['cont] must not appear as the first
-
+cell in a row.
-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.
 
 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")

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
+for a @tech{block}, @racket[part] (and used for the title in the
-latter case).}
+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
+@history[#:changed "1.1" @elem{Added @racket[color-property] and 
-@tech{style properties} can add arbitrary attributes to a cell's
+                               @racket[background-color-property] support.}]}
-@tt{<td>} tag.}
 
 
 @defstruct[table-columns ([styles (listof style?)])]{

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

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))

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)))

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")))

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