Re: [PATCH] shr: render table with style

[Julien Danjou <julien@danjou.info>]

[-- Attachment #1.1: Type: text/plain, Size: 827 bytes --]

On Tue, Dec 07 2010, Lars Magne Ingebrigtsen wrote:

> Well, if there's more code being run in the common paths, it's going to
> be slower.  :-)  The balance we're looking for is between "render as
> prettily and readably as possible" vs "render fast enough for actual
> use".  And that's a real trade-off. 

I agree, but I'm just suggesting to optimize things based on real data
rather than throwing "it will be slower that way".

It's obvious that it will be slower if we add more code (thanks). But if
the table code execution time (you say it's slow) and what I'm proposing
to add are having a 90/10 execution time ratio, arguing that adding more
stuff is bloating the execution time is not really helpful. :-D

Anyhow, rather than speaking forever I've implemented what I've in mind.

Here is a patch.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0001-shr-correct-table-color-rendering.patch --]
[-- Type: text/x-diff, Size: 15398 bytes --]

From ff42dfacd377a71782416bbc73e289b3bacd1e14 Mon Sep 17 00:00:00 2001
From: Julien Danjou <julien@danjou.info>
Date: Tue, 7 Dec 2010 15:07:44 +0100
Subject: [PATCH] shr: correct table color rendering

Signed-off-by: Julien Danjou <julien@danjou.info>
---
 lisp/shr.el |  249 +++++++++++++++++++++++++++++++++--------------------------
 1 files changed, 140 insertions(+), 109 deletions(-)

diff --git a/lisp/shr.el b/lisp/shr.el
index 4f3af11..83165dc 100644
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -201,12 +201,7 @@ redirects somewhere else."
 	(setq style nil)))
     (if (fboundp function)
 	(funcall function (cdr dom))
-      (shr-generic (cdr dom)))
-    ;; If style is set, then this node has set the color.
-    (when style
-      (shr-colorize-region start (point)
-			   (cdr (assq 'color shr-stylesheet))
-			   (cdr (assq 'background-color shr-stylesheet))))))
+      (shr-generic (cdr dom)))))
 
 (defun shr-generic (cont)
   (dolist (sub cont)
@@ -237,59 +232,73 @@ redirects somewhere else."
   (load "kinsoku" nil t))
 
 (defun shr-insert (text)
-  (when (and (eq shr-state 'image)
-	     (not (string-match "\\`[ \t\n]+\\'" text)))
-    (insert "\n")
-    (setq shr-state nil))
-  (cond
-   ((eq shr-folding-mode 'none)
-    (insert text))
-   (t
-    (when (and (string-match "\\`[ \t\n]" text)
-	       (not (bolp))
-	       (not (eq (char-after (1- (point))) ? )))
-      (insert " "))
-    (dolist (elem (split-string text))
-      (when (and (bolp)
-		 (> shr-indentation 0))
-	(shr-indent))
-      ;; The shr-start is a special variable that is used to pass
-      ;; upwards the first point in the buffer where the text really
-      ;; starts.
-      (unless shr-start
-	(setq shr-start (point)))
-      ;; No space is needed behind a wide character categorized as
-      ;; kinsoku-bol, between characters both categorized as nospace,
-      ;; or at the beginning of a line.
-      (let (prev)
-	(when (and (eq (preceding-char) ? )
-		   (or (= (line-beginning-position) (1- (point)))
-		       (and (shr-char-breakable-p
-			     (setq prev (char-after (- (point) 2))))
-			    (shr-char-kinsoku-bol-p prev))
-		       (and (shr-char-nospace-p prev)
-			    (shr-char-nospace-p (aref elem 0)))))
-	  (delete-char -1)))
-      (insert elem)
-      (let (found)
-	(while (and (> (current-column) shr-width)
-		    (progn
-		      (setq found (shr-find-fill-point))
-		      (not (eolp))))
-	  (when (eq (preceding-char) ? )
-	    (delete-char -1))
-	  (insert "\n")
-	  (unless found
-	    (put-text-property (1- (point)) (point) 'shr-break t)
-	    ;; No space is needed at the beginning of a line.
-	    (when (eq (following-char) ? )
-	      (delete-char 1)))
-	  (when (> shr-indentation 0)
-	    (shr-indent))
-	  (end-of-line))
-	(insert " ")))
-    (unless (string-match "[ \t\n]\\'" text)
-      (delete-char -1)))))
+  (let ((start (point)))
+    (when (and (eq shr-state 'image)
+               (not (string-match "\\`[ \t\n]+\\'" text)))
+      (insert "\n")
+      (setq shr-state nil))
+    (cond
+     ((eq shr-folding-mode 'none)
+      (insert text))
+     (t
+      (when (and (string-match "\\`[ \t\n]" text)
+                 (not (bolp))
+                 (not (eq (char-after (1- (point))) ? )))
+        (insert " "))
+      (dolist (elem (split-string text))
+        (when (and (bolp)
+                   (> shr-indentation 0))
+          (shr-indent))
+        ;; The shr-start is a special variable that is used to pass
+        ;; upwards the first point in the buffer where the text really
+        ;; starts.
+        (unless shr-start
+          (setq shr-start (point)))
+        ;; No space is needed behind a wide character categorized as
+        ;; kinsoku-bol, between characters both categorized as nospace,
+        ;; or at the beginning of a line.
+        (let (prev)
+          (when (and (eq (preceding-char) ? )
+                     (or (= (line-beginning-position) (1- (point)))
+                         (and (shr-char-breakable-p
+                               (setq prev (char-after (- (point) 2))))
+                              (shr-char-kinsoku-bol-p prev))
+                         (and (shr-char-nospace-p prev)
+                              (shr-char-nospace-p (aref elem 0)))))
+            (delete-char -1)))
+        (insert elem)
+        (let (found)
+          (while (and (> (current-column) shr-width)
+                      (progn
+                        (setq found (shr-find-fill-point))
+                        (not (eolp))))
+            (when (eq (preceding-char) ? )
+              (delete-char -1))
+            (insert "\n")
+            (unless found
+              (put-text-property (1- (point)) (point) 'shr-break t)
+              ;; No space is needed at the beginning of a line.
+              (when (eq (following-char) ? )
+                (delete-char 1)))
+            (when (> shr-indentation 0)
+              (shr-indent))
+            (end-of-line))
+          (insert " ")))
+      (unless (string-match "[ \t\n]\\'" text)
+        (delete-char -1))))
+    ;; If style is set, then this insert has set the color.
+    (shr-colorize-with-style start (point))))
+
+(defun shr-colorize-with-style (start end)
+  (shr-colorize-region start end
+                       (cdr (assq 'color shr-stylesheet))
+                       (cdr (assq 'background-color
+                                  shr-stylesheet))))
+
+(defun shr-insert-with-style (&rest text)
+  (let ((start (point)))
+    (apply 'insert text)
+    (shr-colorize-with-style start (point))))
 
 (defun shr-find-fill-point ()
   (when (> (move-to-column shr-width) shr-width)
@@ -379,7 +388,7 @@ redirects somewhere else."
 
 (defun shr-ensure-newline ()
   (unless (zerop (current-column))
-    (insert "\n")))
+    (shr-insert-with-style "\n")))
 
 (defun shr-ensure-paragraph ()
   (unless (bobp)
@@ -387,16 +396,16 @@ redirects somewhere else."
 	(unless (save-excursion
 		  (forward-line -1)
 		  (looking-at " *$"))
-	  (insert "\n"))
+	  (shr-insert-with-style "\n"))
       (if (save-excursion
 	    (beginning-of-line)
 	    (looking-at " *$"))
-	  (insert "\n")
-	(insert "\n\n")))))
+	  (shr-insert-with-style "\n")
+	(shr-insert-with-style "\n\n")))))
 
 (defun shr-indent ()
   (when (> shr-indentation 0)
-    (insert (make-string shr-indentation ? ))))
+    (shr-insert-with-style (make-string shr-indentation ? ))))
 
 (defun shr-fontize-cont (cont &rest types)
   (let (shr-start)
@@ -472,9 +481,9 @@ redirects somewhere else."
 	  ;; beginning of the line.
 	  (when (and (> (current-column) 0)
 		     (> (car (image-size image t)) 400))
-	    (insert "\n"))
+	    (shr-insert-with-style "\n"))
 	  (insert-image image (or alt "*"))))
-    (insert alt)))
+    (shr-insert-with-style alt)))
 
 (defun shr-rescale-image (data)
   (if (or (not (fboundp 'imagemagick-types))
@@ -633,10 +642,9 @@ ones, in case fg and bg are nil."
   (let* ((start (point))
 	 (fgcolor (cdr (assq :fgcolor cont)))
 	 (bgcolor (cdr (assq :bgcolor cont)))
-	 (shr-stylesheet (list (cons 'color fgcolor)
-			       (cons 'background-color bgcolor))))
-    (shr-generic cont)
-    (shr-colorize-region start (point) fgcolor bgcolor)))
+         (shr-stylesheet (shr-style-set 'color fgcolor))
+         (shr-stylesheet (shr-style-set 'background-color bgcolor)))
+    (shr-generic cont)))
 
 (defun shr-tag-style (cont)
   )
@@ -691,6 +699,15 @@ ones, in case fg and bg are nil."
 		    plist)))))
       plist)))
 
+(defun shr-style-set (element value)
+  "Set style ELEMENT to VALUE in `shr-stylesheet'.
+Return a modified copy of `shr-stylesheet'.
+
+If VALUE is nil, do nothing."
+  (if value
+      `((,element . ,value) ,@(remove (assq element shr-stylesheet) shr-stylesheet))
+    shr-stylesheet))
+
 (defun shr-tag-a (cont)
   (let ((url (cdr (assq :href cont)))
         (title (cdr (assq :title cont)))
@@ -726,7 +743,7 @@ ones, in case fg and bg are nil."
 		 (cdr (assq :src cont))))
     (when (and (> (current-column) 0)
 	       (not (eq shr-state 'image)))
-      (insert "\n"))
+      (shr-insert-with-style "\n"))
     (let ((alt (cdr (assq :alt cont)))
 	  (url (or url (cdr (assq :src cont)))))
       (let ((start (point-marker)))
@@ -743,7 +760,7 @@ ones, in case fg and bg are nil."
 		image)
 	    (if (or (not shr-content-function)
 		    (not (setq image (funcall shr-content-function url))))
-		(insert alt)
+		(shr-insert-with-style alt)
 	      (shr-put-image image alt))))
 	 ((or shr-inhibit-images
 	      (and shr-blocked-images
@@ -756,7 +773,7 @@ ones, in case fg and bg are nil."
 	 ((url-is-cached (shr-encode-url url))
 	  (shr-put-image (shr-get-image-data url) alt))
 	 (t
-	  (insert alt)
+	  (shr-insert-with-style alt)
 	  (ignore-errors
 	    (url-retrieve (shr-encode-url url) 'shr-image-fetched
 			  (list (current-buffer) start (point-marker))
@@ -805,12 +822,12 @@ ones, in case fg and bg are nil."
 		(setq shr-list-mode (1+ shr-list-mode)))
 	    "* "))
 	 (shr-indentation (+ shr-indentation (length bullet))))
-    (insert bullet)
+    (shr-insert-with-style bullet)
     (shr-generic cont)))
 
 (defun shr-tag-br (cont)
   (unless (bobp)
-    (insert "\n")
+    (shr-insert-with-style "\n")
     (shr-indent))
   (shr-generic cont))
 
@@ -834,7 +851,12 @@ ones, in case fg and bg are nil."
 
 (defun shr-tag-hr (cont)
   (shr-ensure-newline)
-  (insert (make-string shr-width shr-hr-line) "\n"))
+  (shr-insert-with-style (make-string shr-width shr-hr-line) "\n"))
+
+(defun shr-tag-td (cont)
+  (let* ((bgcolor (cdr (assq :bgcolor cont)))
+         (shr-stylesheet (shr-style-set 'background-color bgcolor)))
+    (shr-generic cont)))
 
 (defun shr-tag-title (cont)
   (shr-heading cont 'bold 'underline))
@@ -842,12 +864,8 @@ ones, in case fg and bg are nil."
 (defun shr-tag-font (cont)
   (let* ((start (point))
          (color (cdr (assq :color cont)))
-         (shr-stylesheet (nconc (list (cons 'color color))
-				shr-stylesheet)))
-    (shr-generic cont)
-    (when color
-      (shr-colorize-region start (point) color
-			   (cdr (assq 'background-color shr-stylesheet))))))
+         (shr-stylesheet (shr-style-set 'color color)))
+    (shr-generic cont)))
 
 ;;; Table rendering algorithm.
 
@@ -896,7 +914,10 @@ ones, in case fg and bg are nil."
 	 (body (or (cdr (assq 'tbody cont)) cont))
 	 (footer (cdr (assq 'tfoot cont)))
          (bgcolor (cdr (assq :bgcolor cont)))
-	 (nheader (if header (shr-max-columns header)))
+         (border-color (cdr (assq :bordercolor cont)))
+         (shr-stylesheet (shr-style-set 'border-color border-color))
+         (shr-stylesheet (shr-style-set 'background-color bgcolor))
+         (nheader (if header (shr-max-columns header)))
 	 (nbody (if body (shr-max-columns body)))
 	 (nfooter (if footer (shr-max-columns footer))))
     (shr-tag-table-1
@@ -947,6 +968,13 @@ ones, in case fg and bg are nil."
 	     (setq result (nconc (shr-find-elements (cdr elem) type) result)))))
     (nreverse result)))
 
+(defun shr-insert-table-border (&rest borders)
+  ;; HACK: we set border-color as being color so
+  ;; `shr-insert-with-style' colorize borders.
+  (let ((shr-stylesheet
+         (shr-style-set 'color (cdr (assq 'border-color shr-stylesheet)))))
+    (apply 'shr-insert-with-style borders)))
+
 (defun shr-insert-table (table widths)
   (shr-insert-table-ruler widths)
   (dolist (row table)
@@ -957,7 +985,7 @@ ones, in case fg and bg are nil."
 		    max)))
       (dotimes (i height)
 	(shr-indent)
-	(insert shr-table-vertical-line "\n"))
+	(shr-insert-table-border shr-table-vertical-line "\n"))
       (dolist (column row)
 	(goto-char start)
 	(let ((lines (nth 2 column))
@@ -966,7 +994,8 @@ ones, in case fg and bg are nil."
 	  (dolist (line lines)
 	    (setq overlay-line (pop overlay-lines))
 	    (end-of-line)
-	    (insert line shr-table-vertical-line)
+            (insert line)
+            (shr-insert-table-border shr-table-vertical-line)
 	    (dolist (overlay overlay-line)
 	      (let ((o (make-overlay (- (point) (nth 0 overlay) 1)
 				     (- (point) (nth 1 overlay) 1)))
@@ -978,20 +1007,20 @@ ones, in case fg and bg are nil."
 	  ;; possibly.
 	  (dotimes (i (- height (length lines)))
 	    (end-of-line)
-	    (insert (make-string (string-width (car lines)) ? )
+	    (shr-insert-table-border (make-string (string-width (car lines)) ? )
 		    shr-table-vertical-line)
 	    (forward-line 1)))))
     (shr-insert-table-ruler widths)))
 
 (defun shr-insert-table-ruler (widths)
-  (when (and (bolp)
-	     (> shr-indentation 0))
-    (shr-indent))
-  (insert shr-table-corner)
-  (dotimes (i (length widths))
-    (insert (make-string (aref widths i) shr-table-horizontal-line)
-	    shr-table-corner))
-  (insert "\n"))
+    (when (and (bolp)
+               (> shr-indentation 0))
+      (shr-indent))
+    (shr-insert-table-border shr-table-corner)
+    (dotimes (i (length widths))
+      (shr-insert-table-border (make-string (aref widths i) shr-table-horizontal-line)
+                             shr-table-corner))
+    (shr-insert-table-border "\n"))
 
 (defun shr-table-widths (table suggested-widths)
   (let* ((length (length suggested-widths))
@@ -1023,21 +1052,23 @@ ones, in case fg and bg are nil."
     widths))
 
 (defun shr-make-table (cont widths &optional fill)
-  (let ((trs nil))
+  (let (trs)
     (dolist (row cont)
       (when (eq (car row) 'tr)
-	(let ((tds nil)
-	      (columns (cdr row))
-	      (i 0)
-	      column)
-	  (while (< i (length widths))
-	    (setq column (pop columns))
-	    (when (or (memq (car column) '(td th))
-		      (null column))
-	      (push (shr-render-td (cdr column) (aref widths i) fill)
-		    tds)
-	      (setq i (1+ i))))
-	  (push (nreverse tds) trs))))
+	(let* ((tds nil)
+               (columns (cdr row))
+               (i 0)
+               (bgcolor (cdr (assq :bgcolor (cdr row))))
+               (shr-stylesheet (shr-style-set 'background-color bgcolor))
+               column)
+          (while (< i (length widths))
+            (setq column (pop columns))
+            (when (or (memq (car column) '(td th))
+                      (null column))
+              (push (shr-render-td (cdr column) (aref widths i) fill)
+                    tds)
+              (setq i (1+ i))))
+          (push (nreverse tds) trs))))
     (nreverse trs)))
 
 (defun shr-render-td (cont width fill)
@@ -1065,12 +1096,12 @@ ones, in case fg and bg are nil."
 	;; If the buffer is totally empty, then put a single blank
 	;; line here.
 	(if (zerop (buffer-size))
-	    (insert (make-string width ? ))
+	    (shr-insert-with-style (make-string width ? ))
 	  ;; Otherwise, fill the buffer.
 	  (while (not (eobp))
 	    (end-of-line)
 	    (when (> (- width (current-column)) 0)
-	      (insert (make-string (- width (current-column)) ? )))
+	      (shr-insert-with-style (make-string (- width (current-column)) ? )))
 	    (forward-line 1))))
       (if fill
 	  (list max
-- 
1.7.2.3


[-- Attachment #1.3: Type: text/plain, Size: 2084 bytes --]


I've used the following data example to test the rendering:

#+begin_src html
<body bgcolor="yellow">
Yellow background
<div style="background-color: green;">Green background with a green HR
<hr>
<ul><li>Does the point has green bg</li></ul>
</div>
<div style="color: red; background-color: white;">
  Red on white
  <table bgcolor="black" bordercolor="pink">
    <tr><td>black background table with red text</td><td>bar</td></tr>
    <tr><td bgcolor="blue"> blue bg td with red text</td><td>foobeat</td></tr>
    <tr bgcolor="orange"><td>orange bg tr with red text</td><td>baz</td></tr>
  </table>
  <div style="color: white;">
    white text on white background
    <font color="orange">Orange text on white background</font>
    <div>Same old, same old</div>
  </div>
  <div style="color: blue;">
    Blue text on white background
  </div>
</body>
#+end_src

I've counted 15 color rendering points in it that should be rendered
correctly. Based on that, I've benchmarked the execution time and the
number of rendering point correctly done on current master version and
with my patched version.

So based on my version of the ACID test :-) this is the result I got:

|---------+---------------------+-------------------|
| Version | Execution time x100 | Correct rendering |
|---------+---------------------+-------------------|
| master  |                0.96 | 7/15              |
| jd      |                1.64 | 15/15             |
|---------+---------------------+-------------------|

Benchmark runs with:
(benchmark-run-compiled 100
  (shr-insert-document
    (libxml-parse-html-region
       (point-min) (point-max))))

With my patch the code is 58 % slower but passes twice more tests (and
probably more, actually, I did not bother to make the numbers show how
lame the current code is :-P).

Of course, you're free to reject my patch… or enhance it. :) I've tried
a bit of elp on it, but I do not see anything obvious to cut.

Cheers,
-- 
Julien Danjou
// ᐰ <julien@danjou.info>   http://julien.danjou.info

[-- Attachment #2: Type: application/pgp-signature, Size: 197 bytes --]