From mboxrd@z Thu Jan 1 00:00:00 1970 X-Msuck: nntp://news.gmane.io/gmane.emacs.gnus.general/74833 Path: news.gmane.org!not-for-mail From: Julien Danjou Newsgroups: gmane.emacs.gnus.general Subject: Re: [PATCH] shr: render table with style Date: Tue, 07 Dec 2010 16:27:56 +0100 Message-ID: References: <1291656608-16263-1-git-send-email-julien@danjou.info> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/signed; boundary="==-=-="; micalg=pgp-sha1; protocol="application/pgp-signature" X-Trace: dough.gmane.org 1291735695 26753 80.91.229.12 (7 Dec 2010 15:28:15 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Tue, 7 Dec 2010 15:28:15 +0000 (UTC) To: ding@gnus.org Original-X-From: ding-owner+M23189@lists.math.uh.edu Tue Dec 07 16:28:11 2010 Return-path: Envelope-to: ding-account@gmane.org Original-Received: from util0.math.uh.edu ([129.7.128.18]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1PPzSc-0000CG-Ji for ding-account@gmane.org; Tue, 07 Dec 2010 16:28:11 +0100 Original-Received: from localhost ([127.0.0.1] helo=lists.math.uh.edu) by util0.math.uh.edu with smtp (Exim 4.63) (envelope-from ) id 1PPzSZ-0004D3-Um; Tue, 07 Dec 2010 09:28:08 -0600 Original-Received: from mx2.math.uh.edu ([129.7.128.33]) by util0.math.uh.edu with esmtps (TLSv1:AES256-SHA:256) (Exim 4.63) (envelope-from ) id 1PPzSX-0004Cj-P2 for ding@lists.math.uh.edu; Tue, 07 Dec 2010 09:28:05 -0600 Original-Received: from quimby.gnus.org ([80.91.231.51]) by mx2.math.uh.edu with esmtp (Exim 4.72) (envelope-from ) id 1PPzSV-0002Lg-52 for ding@lists.math.uh.edu; Tue, 07 Dec 2010 09:28:05 -0600 Original-Received: from coquelicot-s.easter-eggs.com ([213.215.37.94]) by quimby.gnus.org with esmtp (Exim 3.36 #1 (Debian)) id 1PPzSU-0003r0-00 for ; Tue, 07 Dec 2010 16:28:02 +0100 Original-Received: from cigue.easter-eggs.fr (cigue.easter-eggs.fr [10.0.0.33]) by rose.easter-eggs.fr (Postfix) with ESMTPS id A51A41415C for ; Tue, 7 Dec 2010 16:27:53 +0100 (CET) Original-Received: from jdanjou by cigue.easter-eggs.fr with local (Exim 4.72) (envelope-from ) id 1PPzSP-0002sq-1G for ding@gnus.org; Tue, 07 Dec 2010 16:27:57 +0100 Mail-Followup-To: ding@gnus.org In-Reply-To: (Lars Magne Ingebrigtsen's message of "Tue, 07 Dec 2010 13:32:48 +0100") User-Agent: Gnus/5.110011 (No Gnus v0.11) Emacs/24.0.50 (gnu/linux) X-Spam-Score: -1.9 (-) List-ID: Precedence: bulk Xref: news.gmane.org gmane.emacs.gnus.general:74833 Archived-At: --==-=-= Content-Type: multipart/mixed; boundary="=-=-=" --=-=-= Content-Type: text/plain Content-Transfer-Encoding: quoted-printable 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.=20 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. --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-shr-correct-table-color-rendering.patch Content-Transfer-Encoding: quoted-printable From=20ff42dfacd377a71782416bbc73e289b3bacd1e14 Mon Sep 17 00:00:00 2001 From: Julien Danjou Date: Tue, 7 Dec 2010 15:07:44 +0100 Subject: [PATCH] shr: correct table color rendering Signed-off-by: Julien Danjou =2D-- 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 =2D-- 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)) =2D (shr-generic (cdr dom))) =2D ;; If style is set, then this node has set the color. =2D (when style =2D (shr-colorize-region start (point) =2D (cdr (assq 'color shr-stylesheet)) =2D (cdr (assq 'background-color shr-stylesheet)))))) + (shr-generic (cdr dom))))) =20 (defun shr-generic (cont) (dolist (sub cont) @@ -237,59 +232,73 @@ redirects somewhere else." (load "kinsoku" nil t)) =20 (defun shr-insert (text) =2D (when (and (eq shr-state 'image) =2D (not (string-match "\\`[ \t\n]+\\'" text))) =2D (insert "\n") =2D (setq shr-state nil)) =2D (cond =2D ((eq shr-folding-mode 'none) =2D (insert text)) =2D (t =2D (when (and (string-match "\\`[ \t\n]" text) =2D (not (bolp)) =2D (not (eq (char-after (1- (point))) ? ))) =2D (insert " ")) =2D (dolist (elem (split-string text)) =2D (when (and (bolp) =2D (> shr-indentation 0)) =2D (shr-indent)) =2D ;; The shr-start is a special variable that is used to pass =2D ;; upwards the first point in the buffer where the text really =2D ;; starts. =2D (unless shr-start =2D (setq shr-start (point))) =2D ;; No space is needed behind a wide character categorized as =2D ;; kinsoku-bol, between characters both categorized as nospace, =2D ;; or at the beginning of a line. =2D (let (prev) =2D (when (and (eq (preceding-char) ? ) =2D (or (=3D (line-beginning-position) (1- (point))) =2D (and (shr-char-breakable-p =2D (setq prev (char-after (- (point) 2)))) =2D (shr-char-kinsoku-bol-p prev)) =2D (and (shr-char-nospace-p prev) =2D (shr-char-nospace-p (aref elem 0))))) =2D (delete-char -1))) =2D (insert elem) =2D (let (found) =2D (while (and (> (current-column) shr-width) =2D (progn =2D (setq found (shr-find-fill-point)) =2D (not (eolp)))) =2D (when (eq (preceding-char) ? ) =2D (delete-char -1)) =2D (insert "\n") =2D (unless found =2D (put-text-property (1- (point)) (point) 'shr-break t) =2D ;; No space is needed at the beginning of a line. =2D (when (eq (following-char) ? ) =2D (delete-char 1))) =2D (when (> shr-indentation 0) =2D (shr-indent)) =2D (end-of-line)) =2D (insert " "))) =2D (unless (string-match "[ \t\n]\\'" text) =2D (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 (=3D (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)))) =20 (defun shr-find-fill-point () (when (> (move-to-column shr-width) shr-width) @@ -379,7 +388,7 @@ redirects somewhere else." =20 (defun shr-ensure-newline () (unless (zerop (current-column)) =2D (insert "\n"))) + (shr-insert-with-style "\n"))) =20 (defun shr-ensure-paragraph () (unless (bobp) @@ -387,16 +396,16 @@ redirects somewhere else." (unless (save-excursion (forward-line -1) (looking-at " *$")) =2D (insert "\n")) + (shr-insert-with-style "\n")) (if (save-excursion (beginning-of-line) (looking-at " *$")) =2D (insert "\n") =2D (insert "\n\n"))))) + (shr-insert-with-style "\n") + (shr-insert-with-style "\n\n"))))) =20 (defun shr-indent () (when (> shr-indentation 0) =2D (insert (make-string shr-indentation ? )))) + (shr-insert-with-style (make-string shr-indentation ? )))) =20 (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)) =2D (insert "\n")) + (shr-insert-with-style "\n")) (insert-image image (or alt "*")))) =2D (insert alt))) + (shr-insert-with-style alt))) =20 (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))) =2D (shr-stylesheet (list (cons 'color fgcolor) =2D (cons 'background-color bgcolor)))) =2D (shr-generic cont) =2D (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))) =20 (defun shr-tag-style (cont) ) @@ -691,6 +699,15 @@ ones, in case fg and bg are nil." plist))))) plist))) =20 +(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-st= ylesheet)) + 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))) =2D (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)))) =2D (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 =2D (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)))) =2D (insert bullet) + (shr-insert-with-style bullet) (shr-generic cont))) =20 (defun shr-tag-br (cont) (unless (bobp) =2D (insert "\n") + (shr-insert-with-style "\n") (shr-indent)) (shr-generic cont)) =20 @@ -834,7 +851,12 @@ ones, in case fg and bg are nil." =20 (defun shr-tag-hr (cont) (shr-ensure-newline) =2D (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))) =20 (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))) =2D (shr-stylesheet (nconc (list (cons 'color color)) =2D shr-stylesheet))) =2D (shr-generic cont) =2D (when color =2D (shr-colorize-region start (point) color =2D (cdr (assq 'background-color shr-stylesheet)))))) + (shr-stylesheet (shr-style-set 'color color))) + (shr-generic cont))) =20 ;;; Table rendering algorithm. =20 @@ -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))) =2D (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))) =20 +(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) =2D (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) =2D (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) =2D (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))) =20 (defun shr-insert-table-ruler (widths) =2D (when (and (bolp) =2D (> shr-indentation 0)) =2D (shr-indent)) =2D (insert shr-table-corner) =2D (dotimes (i (length widths)) =2D (insert (make-string (aref widths i) shr-table-horizontal-line) =2D shr-table-corner)) =2D (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-hori= zontal-line) + shr-table-corner)) + (shr-insert-table-border "\n")) =20 (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)) =20 (defun shr-make-table (cont widths &optional fill) =2D (let ((trs nil)) + (let (trs) (dolist (row cont) (when (eq (car row) 'tr) =2D (let ((tds nil) =2D (columns (cdr row)) =2D (i 0) =2D column) =2D (while (< i (length widths)) =2D (setq column (pop columns)) =2D (when (or (memq (car column) '(td th)) =2D (null column)) =2D (push (shr-render-td (cdr column) (aref widths i) fill) =2D tds) =2D (setq i (1+ i)))) =2D (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))) =20 (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)) =2D (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) =2D (insert (make-string (- width (current-column)) ? ))) + (shr-insert-with-style (make-string (- width (current-column)) ? ))) (forward-line 1)))) (if fill (list max =2D-=20 1.7.2.3 --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable I've used the following data example to test the rendering: #+begin_src html Yellow background
Green background with a green HR
  • Does the point has green bg
Red on white = <= /tr>
black background table with red textbar
blue bg td with red textfoobeat
orange bg tr with red textbaz
white text on white background Orange text on white background
Same old, same old
Blue text on white background
#+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=E2=80=A6 or enhance it. :) I've t= ried a bit of elp on it, but I do not see anything obvious to cut. Cheers, =2D-=20 Julien Danjou // =E1=90=B0 http://julien.danjou.info --=-=-=-- --==-=-= Content-Type: application/pgp-signature -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.10 (GNU/Linux) iEYEARECAAYFAkz+UnwACgkQpGK1HsL+5c3w0wCeK+20ERT+agIi++L+zll39XYa 7AUAnRimPvBvtG/StRnN+MoqWlBalqYb =ZzbC -----END PGP SIGNATURE----- --==-=-=--