commit feed786915968b3363c6c13a9684ce97a6310280
parent e5ebb45c066c9409b5dd2e50ab66e9188335df8b
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 24 Jun 2014 11:25:54 +0100
scribble: 'border and '{left,right,top,bottom}-border properties for cells
original commit: 2134dbf95293189d6f11bf896a3ba43d9fb10aaf
Diffstat:
8 files changed, 282 insertions(+), 68 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -0,0 +1,8 @@
+ --------
+Apple| B B2 |Cat |
+ |------| |
+ ||T || |
+ |------| |
+ -----------------
+C |D |Elephant|
+ -----------------
