From feed786915968b3363c6c13a9684ce97a6310280 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Jun 2014 11:25:54 +0100 Subject: [PATCH] scribble: 'border and '{left,right,top,bottom}-border properties for cells original commit: 2134dbf95293189d6f11bf896a3ba43d9fb10aaf --- .../scribblings/scribble/base.scrbl | 2 + .../scribblings/scribble/core.scrbl | 14 +- pkgs/scribble-pkgs/scribble-lib/info.rkt | 2 +- .../scribble-lib/scribble/html-render.rkt | 40 ++++- .../scribble-lib/scribble/latex-render.rkt | 115 ++++++++++--- .../scribble-lib/scribble/text-render.rkt | 160 +++++++++++++----- .../tests/scribble/docs/table-border.scrbl | 9 + .../tests/scribble/docs/table-border.txt | 8 + 8 files changed, 282 insertions(+), 68 deletions(-) create mode 100644 pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table-border.scrbl create mode 100644 pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table-border.txt diff --git a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/base.scrbl b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/base.scrbl index 3d3d9ba3..0923f5d1 100644 --- a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/base.scrbl +++ b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/base.scrbl @@ -332,6 +332,7 @@ Examples: @tabular[#:style 'boxed #:column-properties '(left right) + #:row-properties '(bottom-border ()) (list (list @bold{recipe} @bold{vegetable}) (list "caldo verde" "kale") (list "kinpira gobō" "burdock") @@ -344,6 +345,7 @@ Examples: @tabular[#:style 'boxed #:column-properties '(left right) + #:row-properties '(bottom-border ()) (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 89acf33c..f01e5800 100644 --- a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/core.scrbl +++ b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/core.scrbl @@ -1152,6 +1152,15 @@ The following are recognized as cell-@tech{style properties}: @item{@racket['vcenter] --- Center the cell content vertically.} + @item{@racket['border] --- Draw a line around all sides of the + cell. Borders along a shared edge of adjacent cells are + collapsed into a single line.} + + @item{@racket['left-border], @racket['right-border], + @racket['top-border], or @racket['bottom-border] --- Draw a + line along the corresponding side of the cell (with the same + border collapsing as for @racket['border]).} + @item{@racket[color-property] structure --- For HTML, applies a color to the cell content.} @@ -1164,7 +1173,10 @@ The following are recognized as cell-@tech{style properties}: ] @history[#:changed "1.1" @elem{Added @racket[color-property] and - @racket[background-color-property] support.}]} + @racket[background-color-property] support.} + #:changed "1.4" @elem{Added @racket['border], @racket['left-border], + @racket['right-border], @racket['top-border], + and @racket['bottom-border] support.}]} @defstruct[table-columns ([styles (listof style?)])]{ diff --git a/pkgs/scribble-pkgs/scribble-lib/info.rkt b/pkgs/scribble-pkgs/scribble-lib/info.rkt index 3876a14e..a18088dd 100644 --- a/pkgs/scribble-pkgs/scribble-lib/info.rkt +++ b/pkgs/scribble-pkgs/scribble-lib/info.rkt @@ -21,4 +21,4 @@ (define pkg-authors '(mflatt eli)) -(define version "1.3") +(define version "1.4") diff --git a/pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt b/pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt index ee44f32a..9103f6a5 100644 --- a/pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt +++ b/pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt @@ -1541,7 +1541,21 @@ (or (attributes? a) (color-property? a) (background-color-property? a))) - (style-properties column-style)))) + (style-properties column-style))) + (let ([ps (style-properties column-style)]) + (cond + [(memq 'border ps) + `([style "border: 1px solid black;"])] + [else + (define (check sym sfx) + (if (memq sym ps) + `([style ,(format "border-~a: 1px solid black;" sfx)]) + null)) + (append + (check 'top-border 'top) + (check 'bottom-border 'bottom) + (check 'left-border 'left) + (check 'right-border 'right))]))) null) ,@(if (and (pair? (cdr ds)) (eq? 'cont (cadr ds))) @@ -1558,16 +1572,30 @@ (render-content (paragraph-content d) part ri) (render-block d part ri #f))) (loop (cdr ds) (cdr column-styles) #f)))])))) + (define cell-styless (extract-table-cell-styles t)) `((table ([cellspacing "0"] - ,@(if starting-item? - '([style "display: inline-table; vertical-align: text-top;"]) - null) + [cellpadding "0"] ,@(combine-class (case (style-name (table-style t)) [(boxed) '([class "boxed"])] [(centered) '([align "center"])] [else '()]) - (style->attribs (table-style t)))) + (style->attribs (table-style t) + (append + (if starting-item? + '([style "display: inline-table; vertical-align: text-top;"]) + null) + (if (for/or ([cell-styles (in-list cell-styless)]) + (for/or ([cell-style (in-list cell-styles)]) + (and cell-style + (let ([ps (style-properties cell-style)]) + (or (memq 'border ps) + (memq 'left-border ps) + (memq 'right-border ps) + (memq 'bottom-border ps) + (memq 'top-border ps)))))) + `([style "border-collapse: collapse;"]) + '()))))) ,@(let ([columns (ormap (lambda (p) (and (table-columns? p) (map (lambda (s) @@ -1587,7 +1615,7 @@ `((tr (td))) (map make-row (table-blockss t) - (extract-table-cell-styles t)))))) + cell-styless))))) (define/override (render-nested-flow t part ri starting-item?) `((,(or (style->tag (nested-flow-style t)) 'blockquote) diff --git a/pkgs/scribble-pkgs/scribble-lib/scribble/latex-render.rkt b/pkgs/scribble-pkgs/scribble-lib/scribble/latex-render.rkt index 863790c0..01f45fa3 100644 --- a/pkgs/scribble-pkgs/scribble-lib/scribble/latex-render.rkt +++ b/pkgs/scribble-pkgs/scribble-lib/scribble/latex-render.rkt @@ -566,6 +566,21 @@ (when (string? s-name) (printf "\\end{~a}" s-name))) (unless (or (null? blockss) (null? (car blockss))) + (define all-left-line?s + (if (null? cell-styless) + null + (for/list ([i (in-range (length (car cell-styless)))]) + (for/and ([cell-styles (in-list cell-styless)]) + (let ([cell-style (list-ref cell-styles i)]) + (or (memq 'left-border (style-properties cell-style)) + (memq 'border (style-properties cell-style)))))))) + (define all-right-line? + (and (pair? cell-styless) + (let ([i (sub1 (length (car cell-styless)))]) + (for/and ([cell-styles (in-list cell-styless)]) + (let ([cell-style (list-ref cell-styles i)]) + (or (memq 'right-border (style-properties cell-style)) + (memq 'border (style-properties cell-style)))))))) (parameterize ([current-table-mode (if inline? (current-table-mode) (list tableform t))] [show-link-page-numbers @@ -589,40 +604,98 @@ "") (string-append* (let ([l - (map (lambda (i cell-style) - (format "~a@{}" + (map (lambda (i cell-style left-line?) + (format "~a~a@{}" + (if left-line? "|@{}" "") (cond [(memq 'center (style-properties cell-style)) "c"] [(memq 'right (style-properties cell-style)) "r"] [else "l"]))) (car blockss) - (car cell-styless))]) - (if boxed? (cons "@{\\SBoxedLeft}" l) l))) + (car cell-styless) + all-left-line?s)]) + (let ([l (if all-right-line? (append l '("|")) l)]) + (if boxed? (cons "@{\\SBoxedLeft}" l) l)))) "")]) + ;; Helper to add row-separating lines: + (define (add-clines prev-styles next-styles) + (let loop ([pos 1] [start #f] [prev-styles prev-styles] [next-styles next-styles]) + (cond + [(or (and prev-styles (null? prev-styles)) + (and next-styles (null? next-styles))) + (when start + (if (= start 1) + (printf "\\hline ") + (printf "\\cline{~a-~a}" start (sub1 pos))))] + [else + (define prev-style (and prev-styles (car prev-styles))) + (define next-style (and next-styles (car next-styles))) + (define line? (or (and prev-style + (or (memq 'bottom-border (style-properties prev-style)) + (memq 'border (style-properties prev-style)))) + (and next-style + (or (memq 'top-border (style-properties next-style)) + (memq 'border (style-properties next-style)))))) + (when (and start (not line?)) + (printf "\\cline{~a-~a}" start (sub1 pos))) + (loop (add1 pos) (and line? (or start pos)) + (and prev-styles (cdr prev-styles)) + (and next-styles (cdr next-styles)))]))) + ;; Loop through rows: (let loop ([blockss blockss] - [cell-styless cell-styless]) + [cell-styless cell-styless] + [prev-styles #f]) ; for 'bottom-border styles (let ([flows (car blockss)] [cell-styles (car cell-styless)]) + (unless index? (add-clines prev-styles cell-styles)) (let loop ([flows flows] - [cell-styles cell-styles]) + [cell-styles cell-styles] + [all-left-line?s all-left-line?s] + [need-left? #f]) (unless (null? flows) - (when index? (printf "\n\\item ")) - (unless (eq? 'cont (car flows)) - (let ([cnt (let loop ([flows (cdr flows)][n 1]) - (cond [(null? flows) n] - [(eq? (car flows) 'cont) - (loop (cdr flows) (add1 n))] - [else n]))]) - (unless (= cnt 1) (printf "\\multicolumn{~a}{l}{" cnt)) - (render-table-cell (car flows) part ri (/ twidth cnt) (car cell-styles) (not index?)) - (unless (= cnt 1) (printf "}")) - (unless (null? (list-tail flows cnt)) (printf " &\n")))) + (define right-line? + (cond + [index? + (printf "\n\\item ") + #f] + [(eq? 'cont (car flows)) + #f] + [else + (let ([cnt (let loop ([flows (cdr flows)][n 1]) + (cond [(null? flows) n] + [(eq? (car flows) 'cont) + (loop (cdr flows) (add1 n))] + [else n]))]) + (unless (= cnt 1) (printf "\\multicolumn{~a}{l}{" cnt)) + (when (and (not (car all-left-line?s)) + (or need-left? + (memq 'left-border (style-properties (car cell-styles))) + (memq 'border (style-properties (car cell-styles))))) + (printf "\\vline ")) + (render-table-cell (car flows) part ri (/ twidth cnt) (car cell-styles) (not index?)) + (define right-line? (or (memq 'right-border (style-properties (list-ref cell-styles (sub1 cnt)))) + (memq 'border (style-properties (list-ref cell-styles (sub1 cnt)))))) + (when (and right-line? (null? (list-tail flows cnt)) (not all-right-line?)) + (printf "\\vline ")) + (unless (= cnt 1) (printf "}")) + (unless (null? (list-tail flows cnt)) + (printf " &\n")) + right-line?)])) (unless (null? (cdr flows)) (loop (cdr flows) - (cdr cell-styles))))) - (unless (or index? (null? (cdr blockss))) + (cdr cell-styles) + (cdr all-left-line?s) + right-line?)))) + (unless (or index? + (and (null? (cdr blockss)) + (not (for/or ([cell-style (in-list cell-styles)]) + (or (memq 'bottom-border (style-properties cell-style)) + (memq 'border (style-properties cell-style))))))) (printf " \\\\\n")) - (unless (null? (cdr blockss)) - (loop (cdr blockss) (cdr cell-styless))))) + (cond + [(null? (cdr blockss)) + (unless index? (add-clines cell-styles #f))] + [else + (loop (cdr blockss) (cdr cell-styless) cell-styles)]))) (unless inline? (printf "\\end{~a}~a" tableform diff --git a/pkgs/scribble-pkgs/scribble-lib/scribble/text-render.rkt b/pkgs/scribble-pkgs/scribble-lib/scribble/text-render.rkt index e297b25c..22f3718c 100644 --- a/pkgs/scribble-pkgs/scribble-lib/scribble/text-render.rkt +++ b/pkgs/scribble-pkgs/scribble-lib/scribble/text-render.rkt @@ -88,66 +88,148 @@ (regexp-replace #rx"\n$" (get-output-string o) ""))))) flows)) flowss)] + [extract-align + (lambda (s) + (define p (style-properties s)) + (cond + [(member 'right p) 'right] + [(member 'center p) 'center] + [else 'left]))] [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]))))] + (extract-align s))))] [(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]))))] + (extract-align s))))] [else (if (null? flowss) null (make-list (length flowss) (make-list (length (car flowss)) 'left)))])] + [extract-border + (lambda (s) + (define p (style-properties s)) + (cond + [(memq 'border p) '#(#t #t #t #t)] + [else + (vector (memq 'left-border p) (memq 'right-border p) + (memq 'top-border p) (memq 'bottom-border p))]))] + [borderss + ;; A border is (vector left? right? top? bottom?) + (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)]) + (extract-border s))))] + [(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))]) + (extract-border s))))] + [else + (if (null? flowss) + null + (make-list (length flowss) (make-list (length (car flowss)) '#(#f #f #f #f))))])] + [border-left? (lambda (v) (vector-ref v 0))] + [border-right? (lambda (v) (vector-ref v 1))] + [border-top? (lambda (v) (vector-ref v 2))] + [border-bottom? (lambda (v) (vector-ref v 3))] + [col-borders ; has only left and right + (for/list ([i (in-range (length (car borderss)))]) + (for/fold ([v '#(#f #f)]) ([borders (in-list borderss)]) + (define v2 (list-ref borders i)) + (vector (or (border-left? v) (border-left? v2)) + (or (border-right? v) (border-right? v2)))))] [widths (map (lambda (col) (for/fold ([d 0]) ([i (in-list col)]) (if (eq? i 'cont) - 0 + d (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)] - [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)]) - (if (i . < . (x-length col)) - (list-ref col i) - "")))]) - (for/fold ([indent? indent?]) ([sub-row (in-list row*)]) - (when indent? (indent)) - (for/fold ([space? #f]) - ([col (in-list sub-row)] - [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) - (case align - [(left) (display (make-string gap #\space))] - [(center) (display (make-string (- gap (quotient gap 2)) #\space))])) - #t) - (newline) - #t))) - #t) + + (define (show-row-border prev-borders borders) + (when (for/or ([prev-border (in-list prev-borders)] + [border (in-list borders)]) + (or (border-bottom? prev-border) + (border-top? border))) + (define-values (end-h-border? end-v-border?) + (for/fold ([left-border? #f] + [prev-border? #f]) + ([w (in-list widths)] + [prev-border (in-list prev-borders)] + [border (in-list borders)] + [col-border (in-list col-borders)]) + (define border? (or (and prev-border (border-bottom? prev-border)) + (border-top? border))) + (when (or left-border? (border-left? col-border)) + (display (if (or prev-border? border?) "-" " "))) + (display (make-string w (if border? #\- #\space))) + (values (border-right? col-border) border?))) + (when end-h-border? + (display (if end-v-border? "-" " "))) + (newline))) + + (define-values (last-indent? last-borders) + (for/fold ([indent? #f] [prev-borders #f]) ([row (in-list strs)] + [aligns (in-list alignss)] + [borders (in-list borderss)]) + (values + (let ([h (apply max 0 (map x-length row))]) + (let ([row* (for/list ([i (in-range h)]) + (for/list ([col (in-list row)]) + (if (i . < . (x-length col)) + (list-ref col i) + (if (eq? col 'cont) + 'cont + ""))))]) + (for/fold ([indent? indent?]) ([sub-row (in-list row*)] + [pos (in-naturals)]) + (when indent? (indent)) + + (when (zero? pos) + (show-row-border (or prev-borders (map (lambda (b) '#(#f #f #f #f)) borders)) + borders)) + + (define-values (end-border? end-col-border?) + (for/fold ([left-border? #f] [left-col-border? #f]) + ([col (in-list sub-row)] + [w (in-list widths)] + [align (in-list aligns)] + [border (in-list borders)] + [col-border (in-list col-borders)]) + (when (or left-col-border? (border-left? col-border)) + (display (if (and (or left-border? (border-left? border)) + (not (eq? col 'cont))) + "|" + " "))) + (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) + (case align + [(left) (display (make-string gap #\space))] + [(center) (display (make-string (- gap (quotient gap 2)) #\space))])) + (values (border-right? border) + (border-right? col-border)))) + (when end-col-border? + (display (if end-border? "|" " "))) + (newline) + #t))) + borders))) + + (show-row-border last-borders (map (lambda (b) '#(#f #f #f #f)) last-borders)) + null))) (define/override (render-itemization i part ht) diff --git a/pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table-border.scrbl b/pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table-border.scrbl new file mode 100644 index 00000000..cab4b72c --- /dev/null +++ b/pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table-border.scrbl @@ -0,0 +1,9 @@ +#lang scribble/base +@(require scribble/decode) + +@(define sub-table (tabular #:row-properties (list null '(border)) + '(("B" "B2") ("T" cont)))) + +@tabular[#:column-properties (list null '(border) '(bottom-border right-border)) + (list (list "Apple" sub-table "Cat") (list "C" "D" "Elephant")) +] diff --git a/pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table-border.txt b/pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table-border.txt new file mode 100644 index 00000000..1341cabc --- /dev/null +++ b/pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table-border.txt @@ -0,0 +1,8 @@ + -------- +Apple| B B2 |Cat | + |------| | + ||T || | + |------| | + ----------------- +C |D |Elephant| + -----------------