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{} 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{
} 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{} tag.} + ] -In addition, for HTML output, @racket[attributes] structures as -@tech{style properties} can add arbitrary attributes to a cell's -@tt{} 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