suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

scribble: 'border and '{left,right,top,bottom}-border properties for cells

Browse Source 
original commit: 2134dbf95293189d6f11bf896a3ba43d9fb10aaf
This commit is contained in:
Matthew Flatt 2014-06-24 11:25:54 +01:00
parent e5ebb45c06
commit feed786915
8 changed files with 282 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/base.scrbl
View File

@ -332,6 +332,7 @@ Examples:
@tabular[#:style 'boxed @tabular[#:style 'boxed
#:column-properties '(left right) #:column-properties '(left right)
#:row-properties '(bottom-border ())
(list (list @bold{recipe} @bold{vegetable}) (list (list @bold{recipe} @bold{vegetable})
(list "caldo verde" "kale") (list "caldo verde" "kale")
(list "kinpira gobō" "burdock") (list "kinpira gobō" "burdock")
@ -344,6 +345,7 @@ Examples:
@tabular[#:style 'boxed @tabular[#:style 'boxed
#:column-properties '(left right) #:column-properties '(left right)
#:row-properties '(bottom-border ())
(list (list @bold{recipe} @bold{vegetable}) (list (list @bold{recipe} @bold{vegetable})
(list "caldo verde" "kale") (list "caldo verde" "kale")
(list "kinpira gobō" "burdock") (list "kinpira gobō" "burdock")

14
pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/core.scrbl
View File

@ -1152,6 +1152,15 @@ The following are recognized as cell-@tech{style properties}:
@item{@racket['vcenter] --- Center the cell content vertically.} @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 @item{@racket[color-property] structure --- For HTML, applies a color
to the cell content.} 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 @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?)])]{ @defstruct[table-columns ([styles (listof style?)])]{

2
pkgs/scribble-pkgs/scribble-lib/info.rkt
View File

@ -21,4 +21,4 @@
(define pkg-authors '(mflatt eli)) (define pkg-authors '(mflatt eli))
(define version "1.3") (define version "1.4")

40
pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt
View File

@ -1541,7 +1541,21 @@
(or (attributes? a) (or (attributes? a)
(color-property? a) (color-property? a)
(background-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) null)
,@(if (and (pair? (cdr ds)) ,@(if (and (pair? (cdr ds))
(eq? 'cont (cadr ds))) (eq? 'cont (cadr ds)))
@ -1558,16 +1572,30 @@
(render-content (paragraph-content d) part ri) (render-content (paragraph-content d) part ri)
(render-block d part ri #f))) (render-block d part ri #f)))
(loop (cdr ds) (cdr column-styles) #f)))])))) (loop (cdr ds) (cdr column-styles) #f)))]))))
(define cell-styless (extract-table-cell-styles t))
`((table ([cellspacing "0"] `((table ([cellspacing "0"]
,@(if starting-item? [cellpadding "0"]
'([style "display: inline-table; vertical-align: text-top;"])
null)
,@(combine-class ,@(combine-class
(case (style-name (table-style t)) (case (style-name (table-style t))
[(boxed) '([class "boxed"])] [(boxed) '([class "boxed"])]
[(centered) '([align "center"])] [(centered) '([align "center"])]
[else '()]) [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) ,@(let ([columns (ormap (lambda (p)
(and (table-columns? p) (and (table-columns? p)
(map (lambda (s) (map (lambda (s)
@ -1587,7 +1615,7 @@
`((tr (td))) `((tr (td)))
(map make-row (map make-row
(table-blockss t) (table-blockss t)
(extract-table-cell-styles t)))))) cell-styless)))))
(define/override (render-nested-flow t part ri starting-item?) (define/override (render-nested-flow t part ri starting-item?)
`((,(or (style->tag (nested-flow-style t)) 'blockquote) `((,(or (style->tag (nested-flow-style t)) 'blockquote)

115
pkgs/scribble-pkgs/scribble-lib/scribble/latex-render.rkt
View File

@ -566,6 +566,21 @@
(when (string? s-name) (when (string? s-name)
(printf "\\end{~a}" s-name))) (printf "\\end{~a}" s-name)))
(unless (or (null? blockss) (null? (car blockss))) (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 (parameterize ([current-table-mode
(if inline? (current-table-mode) (list tableform t))] (if inline? (current-table-mode) (list tableform t))]
[show-link-page-numbers [show-link-page-numbers
@ -589,40 +604,98 @@
"") "")
(string-append* (string-append*
(let ([l (let ([l
(map (lambda (i cell-style) (map (lambda (i cell-style left-line?)
(format "~a@{}" (format "~a~a@{}"
(if left-line? "|@{}" "")
(cond (cond
[(memq 'center (style-properties cell-style)) "c"] [(memq 'center (style-properties cell-style)) "c"]
[(memq 'right (style-properties cell-style)) "r"] [(memq 'right (style-properties cell-style)) "r"]
[else "l"]))) [else "l"])))
(car blockss) (car blockss)
(car cell-styless))]) (car cell-styless)
(if boxed? (cons "@{\\SBoxedLeft}" l) l))) 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] (let loop ([blockss blockss]
[cell-styless cell-styless]) [cell-styless cell-styless]
[prev-styles #f]) ; for 'bottom-border styles
(let ([flows (car blockss)] (let ([flows (car blockss)]
[cell-styles (car cell-styless)]) [cell-styles (car cell-styless)])
(unless index? (add-clines prev-styles cell-styles))
(let loop ([flows flows] (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) (unless (null? flows)
(when index? (printf "\n\\item ")) (define right-line?
(unless (eq? 'cont (car flows)) (cond
(let ([cnt (let loop ([flows (cdr flows)][n 1]) [index?
(cond [(null? flows) n] (printf "\n\\item ")
[(eq? (car flows) 'cont) #f]
(loop (cdr flows) (add1 n))] [(eq? 'cont (car flows))
[else n]))]) #f]
(unless (= cnt 1) (printf "\\multicolumn{~a}{l}{" cnt)) [else
(render-table-cell (car flows) part ri (/ twidth cnt) (car cell-styles) (not index?)) (let ([cnt (let loop ([flows (cdr flows)][n 1])
(unless (= cnt 1) (printf "}")) (cond [(null? flows) n]
(unless (null? (list-tail flows cnt)) (printf " &\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) (unless (null? (cdr flows)) (loop (cdr flows)
(cdr cell-styles))))) (cdr cell-styles)
(unless (or index? (null? (cdr blockss))) (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")) (printf " \\\\\n"))
(unless (null? (cdr blockss)) (cond
(loop (cdr blockss) (cdr cell-styless))))) [(null? (cdr blockss))
(unless index? (add-clines cell-styles #f))]
[else
(loop (cdr blockss) (cdr cell-styless) cell-styles)])))
(unless inline? (unless inline?
(printf "\\end{~a}~a" (printf "\\end{~a}~a"
tableform tableform

160
pkgs/scribble-pkgs/scribble-lib/scribble/text-render.rkt
View File

@ -88,66 +88,148 @@
(regexp-replace #rx"\n$" (get-output-string o) ""))))) (regexp-replace #rx"\n$" (get-output-string o) "")))))
flows)) flows))
flowss)] flowss)]
[extract-align
(lambda (s)
(define p (style-properties s))
(cond
[(member 'right p) 'right]
[(member 'center p) 'center]
[else 'left]))]
[alignss [alignss
(cond (cond
[(ormap (lambda (v) (and (table-cells? v) v)) (style-properties (table-style i))) [(ormap (lambda (v) (and (table-cells? v) v)) (style-properties (table-style i)))
=> (lambda (tc) => (lambda (tc)
(for/list ([l (in-list (table-cells-styless tc))]) (for/list ([l (in-list (table-cells-styless tc))])
(for/list ([s (in-list l)]) (for/list ([s (in-list l)])
(define p (style-properties s)) (extract-align 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))) [(ormap (lambda (v) (and (table-columns? v) v)) (style-properties (table-style i)))
=> (lambda (tc) => (lambda (tc)
(make-list (make-list
(length flowss) (length flowss)
(for/list ([s (in-list (table-columns-styles tc))]) (for/list ([s (in-list (table-columns-styles tc))])
(define p (style-properties s)) (extract-align s))))]
(cond
[(member 'right p) 'right]
[(member 'center p) 'center]
[else 'left]))))]
[else [else
(if (null? flowss) (if (null? flowss)
null null
(make-list (length flowss) (make-list (length (car flowss)) 'left)))])] (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) [widths (map (lambda (col)
(for/fold ([d 0]) ([i (in-list col)]) (for/fold ([d 0]) ([i (in-list col)])
(if (eq? i 'cont) (if (eq? i 'cont)
0 d
(apply max d (map string-length i))))) (apply max d (map string-length i)))))
(apply map list strs))] (apply map list strs))]
[x-length (lambda (col) (if (eq? col 'cont) 0 (length col)))]) [x-length (lambda (col) (if (eq? col 'cont) 0 (length col)))])
(for/fold ([indent? #f]) ([row (in-list strs)]
[aligns (in-list alignss)]) (define (show-row-border prev-borders borders)
(let ([h (apply max 0 (map x-length row))]) (when (for/or ([prev-border (in-list prev-borders)]
(let ([row* (for/list ([i (in-range h)]) [border (in-list borders)])
(for/list ([col (in-list row)]) (or (border-bottom? prev-border)
(if (i . < . (x-length col)) (border-top? border)))
(list-ref col i) (define-values (end-h-border? end-v-border?)
"")))]) (for/fold ([left-border? #f]
(for/fold ([indent? indent?]) ([sub-row (in-list row*)]) [prev-border? #f])
(when indent? (indent)) ([w (in-list widths)]
(for/fold ([space? #f]) [prev-border (in-list prev-borders)]
([col (in-list sub-row)] [border (in-list borders)]
[w (in-list widths)] [col-border (in-list col-borders)])
[align (in-list aligns)]) (define border? (or (and prev-border (border-bottom? prev-border))
;; (when space? (display " ")) (border-top? border)))
(let ([col (if (eq? col 'cont) "" col)]) (when (or left-border? (border-left? col-border))
(define gap (max 0 (- w (string-length col)))) (display (if (or prev-border? border?) "-" " ")))
(case align (display (make-string w (if border? #\- #\space)))
[(right) (display (make-string gap #\space))] (values (border-right? col-border) border?)))
[(center) (display (make-string (quotient gap 2) #\space))]) (when end-h-border?
(display col) (display (if end-v-border? "-" " ")))
(case align (newline)))
[(left) (display (make-string gap #\space))]
[(center) (display (make-string (- gap (quotient gap 2)) #\space))])) (define-values (last-indent? last-borders)
#t) (for/fold ([indent? #f] [prev-borders #f]) ([row (in-list strs)]
(newline) [aligns (in-list alignss)]
#t))) [borders (in-list borderss)])
#t) (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))) null)))
(define/override (render-itemization i part ht) (define/override (render-itemization i part ht)

9
pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table-border.scrbl Normal file
View File

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

8
pkgs/scribble-pkgs/scribble-test/tests/scribble/docs/table-border.txt Normal file
View File

@ -0,0 +1,8 @@
--------
Apple| B B2 |Cat |
|------| |
||T || |
|------| |
-----------------
C |D |Elephant|
-----------------