Allow using variable-width fonts in eww

* lisp/gnus/mm-decode.el (mm-shr): Only pass the fill column when not using
fonts, because limiting the width to what's appropriate for followups
doesn't really help when not using proportional fonts.

* lisp/net/shr.el (shr-use-fonts): New variable.
(shr-fill-text): Rename from "fold".
(shr-pixel-column, shr-pixel-region, shr-string-pixel-width): New
functions.
(shr-insert): Just insert, don't fill the text.  Filling is now
done afterwards per display unit.
(shr-fill-lines, shr-fill-line): New functions to fill text on a
per-unit base.
(shr-find-fill-point): Take a "beginning" parameter.
(shr-indent): Indent using the :width display parameter when using
fonts.
(shr-parse-style): Ignore "inherit" values, since we already do that.
(shr-tag-img): Remove the insertion states.
(shr-tag-blockquote): New-style filling.
(shr-tag-dd): Ditto.
(shr-tag-li): Ditto.
(shr-mark-fill): New function to mark lines that need filling.
(shr-tag-h1): Use a larger font.
(shr-tag-table-1): Get the natural and suggested widths in one
rendering.
(shr-tag-table): Create the "fixed" version of the table only once
so that we can cache data in the table.
(shr-insert-table): Get colspan calculations right by having
zero-width columns after colspan ones.
(shr-expand-alignments): New function to make :align-to specs work
right when rendered in one buffer and displayed in another one.
(shr-insert-table-ruler): Use :align-to to get the widths right.
(shr-make-table): Cache more.
(shr-make-table-1): Use the new <td> data layout.
(shr-pixel-buffer-width): New function.
(shr-render-td): Add a caching layer.
(shr-dom-max-natural-width): New function.

5 files changed, 513 insertions, 264 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index f7dcb840bd6..d8cb245cbeb 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,38 @@
+2015-02-10  Lars Ingebrigtsen  <larsi@gnus.org>
+
+	* net/shr.el (shr-use-fonts): New variable.
+	(shr-fill-text): Rename from "fold".
+	(shr-pixel-column, shr-pixel-region, shr-string-pixel-width): New
+	functions.
+	(shr-insert): Just insert, don't fill the text.  Filling is now
+	done afterwards per display unit.
+	(shr-fill-lines, shr-fill-line): New functions to fill text on a
+	per-unit base.
+	(shr-find-fill-point): Take a "beginning" parameter.
+	(shr-indent): Indent using the :width display parameter when using
+	fonts.
+	(shr-parse-style): Ignore "inherit" values, since we already do that.
+	(shr-tag-img): Remove the insertion states.
+	(shr-tag-blockquote): New-style filling.
+	(shr-tag-dd): Ditto.
+	(shr-tag-li): Ditto.
+	(shr-mark-fill): New function to mark lines that need filling.
+	(shr-tag-h1): Use a larger font.
+	(shr-tag-table-1): Get the natural and suggested widths in one
+	rendering.
+	(shr-tag-table): Create the "fixed" version of the table only once
+	so that we can cache data in the table.
+	(shr-insert-table): Get colspan calculations right by having
+	zero-width columns after colspan ones.
+	(shr-expand-alignments): New function to make :align-to specs work
+	right when rendered in one buffer and displayed in another one.
+	(shr-insert-table-ruler): Use :align-to to get the widths right.
+	(shr-make-table): Cache more.
+	(shr-make-table-1): Use the new <td> data layout.
+	(shr-pixel-buffer-width): New function.
+	(shr-render-td): Add a caching layer.
+	(shr-dom-max-natural-width): New function.
+
 2015-02-10  Fabián Ezequiel Gallina  <fgallina@gnu.org>
 
 	python.el: Improved shell font lock respecting markers.  (Bug#19650)
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 32d3f08f586..ac7e2acab93 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,15 @@
+2015-02-10  Lars Ingebrigtsen  <larsi@gnus.org>
+
+	* mm-decode.el (mm-shr): Only pass the fill column when not using
+	fonts, because limiting the width to what's appropriate for followups
+	doesn't really help when not using proportional fonts.
+
+2015-02-09  Lars Ingebrigtsen  <larsi@gnus.org>
+
+	* mm-decode.el (mm-convert-shr-links): Don't overwrite the faces from
+	shr, beacause that breaks folding.
+	(mm-shr): Don't shorten the width when using fonts.
+
 2015-02-05  Teodor Zlatanov  <tzz@lifelogs.com>
 
 	* gnus-start.el (gnus-save-newsrc-file-check-timestamp): Remove
diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index 311ea7cffff..6c783bbef03 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -1815,6 +1815,7 @@ If RECURSIVE, search recursively."
 		  (start end &optional base-url))
 (declare-function shr-insert-document "shr" (dom))
 (defvar shr-blocked-images)
+(defvar shr-use-fonts)
 (defvar gnus-inhibit-images)
 (autoload 'gnus-blocked-images "gnus-art")
 
@@ -1822,7 +1823,10 @@ If RECURSIVE, search recursively."
   ;; Require since we bind its variables.
   (require 'shr)
   (let ((article-buffer (current-buffer))
-	(shr-width fill-column)
+	(shr-width (if (and (boundp 'shr-use-fonts)
+			    shr-use-fonts)
+		       nil
+		     fill-column))
 	(shr-content-function (lambda (id)
 				(let ((handle (mm-get-content-id id)))
 				  (when handle
@@ -1890,12 +1894,15 @@ If RECURSIVE, search recursively."
 		(< start (point-max)))
       (when (setq start (text-property-not-all start (point-max) 'shr-url nil))
 	(setq end (next-single-property-change start 'shr-url nil (point-max)))
+	(setq face (get-text-property start 'face))
 	(widget-convert-button
 	 'url-link start end
 	 :help-echo (get-text-property start 'help-echo)
 	 :keymap shr-map
 	 (get-text-property start 'shr-url))
 	(put-text-property start end 'local-map nil)
+	(dolist (overlay (overlays-at start))
+	  (overlay-put overlay 'face nil))
 	(setq start end)))))
 
 (defun mm-handle-filename (handle)
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index ec7a0baacf6..c401701f255 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -409,7 +409,6 @@ See the `eww-search-prefix' variable for the search engine used."
 	       (form . eww-tag-form)
 	       (input . eww-tag-input)
 	       (textarea . eww-tag-textarea)
-	       (body . eww-tag-body)
 	       (select . eww-tag-select)
 	       (link . eww-tag-link)
 	       (a . eww-tag-a))))
@@ -495,15 +494,6 @@ See the `eww-search-prefix' variable for the search engine used."
 	      (replace-regexp-in-string "[ \t\r\n]+" " " (dom-text dom))))
   (eww-update-header-line-format))
 
-(defun eww-tag-body (dom)
-  (let* ((start (point))
-	 (fgcolor (or (dom-attr dom 'fgcolor) (dom-attr dom 'text)))
-	 (bgcolor (dom-attr dom 'bgcolor))
-	 (shr-stylesheet (list (cons 'color fgcolor)
-			       (cons 'background-color bgcolor))))
-    (shr-generic dom)
-    (shr-colorize-region start (point) fgcolor bgcolor)))
-
 (defun eww-display-raw (buffer &optional encode)
   (let ((data (buffer-substring (point) (point-max))))
     (unless (buffer-live-p buffer)
@@ -653,6 +643,7 @@ the like."
     (define-key map "H" 'eww-list-histories)
     (define-key map "E" 'eww-set-character-encoding)
     (define-key map "S" 'eww-list-buffers)
+    (define-key map "F" 'eww-toggle-fonts)
 
     (define-key map "b" 'eww-add-bookmark)
     (define-key map "B" 'eww-list-bookmarks)
@@ -1425,6 +1416,15 @@ Differences in #targets are ignored."
       (eww-reload nil 'utf-8)
     (eww-reload nil charset)))
 
+(defun eww-toggle-fonts ()
+  "Toggle whether to use monospaced or font-enabled layouts."
+  (interactive)
+  (message "Fonts are now %s"
+	   (if (setq shr-use-fonts (not shr-use-fonts))
+	       "on"
+	     "off"))
+  (eww-reload))
+
 ;;; Bookmarks code
 
 (defvar eww-bookmarks nil)
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 59c277b01c2..06a75a46bf2 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -57,6 +57,12 @@ fit these criteria."
   :group 'shr
   :type '(choice (const nil) regexp))
 
+(defcustom shr-use-fonts nil
+  "If non-nil, use proportional fonts for text."
+  :version "25.1"
+  :group 'shr
+  :type 'boolean)
+
 (defcustom shr-table-horizontal-line nil
   "Character used to draw horizontal table lines.
 If nil, don't draw horizontal table lines."
@@ -132,10 +138,9 @@ cid: URL as the argument.")
 ;;; Internal variables.
 
 (defvar shr-folding-mode nil)
-(defvar shr-state nil)
 (defvar shr-start nil)
 (defvar shr-indentation 0)
-(defvar shr-internal-width (or shr-width (1- (window-width))))
+(defvar shr-internal-width nil)
 (defvar shr-list-mode nil)
 (defvar shr-content-cache nil)
 (defvar shr-kinsoku-shorten nil)
@@ -149,6 +154,9 @@ cid: URL as the argument.")
 (defvar shr-target-id nil)
 (defvar shr-inhibit-decoration nil)
 (defvar shr-table-separator-length 1)
+(defvar shr-table-separator-pixel-width 0)
+(defvar shr-table-id nil)
+(defvar shr-current-font nil)
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
@@ -202,13 +210,22 @@ DOM should be a parse tree as generated by
 `libxml-parse-html-region' or similar."
   (setq shr-content-cache nil)
   (let ((start (point))
-	(shr-state nil)
 	(shr-start nil)
 	(shr-base nil)
 	(shr-depth 0)
+	(shr-table-id 0)
 	(shr-warning nil)
-	(shr-internal-width (or shr-width (1- (window-width)))))
+	(shr-table-separator-pixel-width (shr-string-pixel-width "-"))
+	(shr-internal-width (or (and shr-width
+				     (if (not shr-use-fonts)
+					 shr-width
+				       (* shr-width (frame-char-width))))
+				(if (not shr-use-fonts)
+				    (- (window-width) 2)
+				  (- (window-pixel-width)
+				     (* (frame-fringe-width) 2))))))
     (shr-descend dom)
+    (shr-fill-lines start (point))
     (shr-remove-trailing-whitespace start (point))
     (when shr-warning
       (message "%s" shr-warning))))
@@ -303,7 +320,7 @@ redirects somewhere else."
   (let ((text (get-text-property (point) 'shr-alt)))
     (if (not text)
 	(message "No image under point")
-      (message "%s" (shr-fold-text text)))))
+      (message "%s" (shr-fill-text text)))))
 
 (defun shr-browse-image (&optional copy-url)
   "Browse the image under point.
@@ -414,14 +431,14 @@ size, and full-buffer size."
 	   (cdr (assq 'color shr-stylesheet))
 	   (cdr (assq 'background-color shr-stylesheet))))))))
 
-(defun shr-fold-text (text)
+(defun shr-fill-text (text)
   (if (zerop (length text))
       text
     (with-temp-buffer
       (let ((shr-indentation 0)
-	    (shr-state nil)
 	    (shr-start nil)
-	    (shr-internal-width (window-width)))
+	    (shr-internal-width (- (window-pixel-width)
+				   (* (frame-fringe-width) 2))))
 	(shr-insert text)
 	(buffer-string)))))
 
@@ -447,76 +464,123 @@ size, and full-buffer size."
 (unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
   (load "kinsoku" nil t))
 
+(defun shr-pixel-column ()
+  (if (not shr-use-fonts)
+      (current-column)
+    (if (not (get-buffer-window (current-buffer)))
+	(save-window-excursion
+	  (set-window-buffer nil (current-buffer))
+	  (car (window-text-pixel-size nil (line-beginning-position) (point))))
+      (car (window-text-pixel-size nil (line-beginning-position) (point))))))
+
+(defun shr-pixel-region ()
+  (- (shr-pixel-column)
+     (save-excursion
+       (goto-char (mark))
+       (shr-pixel-column))))
+
+(defun shr-string-pixel-width (string)
+  (if (not shr-use-fonts)
+      (length string)
+    (with-temp-buffer
+      (insert string)
+      (shr-pixel-column))))
+
 (defun shr-insert (text)
-  (when (and (eq shr-state 'image)
-	     (not (bolp))
-	     (not (string-match "\\`[ \t\n]+\\'" text)))
-    (insert "\n")
-    (setq shr-state nil))
+  (when (and (not (bolp))
+	     (get-text-property (1- (point)) 'image-url))
+    (insert "\n"))
   (cond
    ((eq shr-folding-mode 'none)
     (insert text))
    (t
-    (when (and (string-match "\\`[ \t\n ]" text)
+    (when (and (string-match "\\`[ \t\n\r ]" text)
 	       (not (bolp))
 	       (not (eq (char-after (1- (point))) ? )))
       (insert " "))
-    (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t))
-      (when (and (bolp)
-		 (> shr-indentation 0))
-	(shr-indent))
-      ;; 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 (> (current-column) shr-indentation)
-		   (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)))
-      ;; 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)))
-      (insert elem)
-      (setq shr-state nil)
-      (let (found)
-	(while (and (> (current-column) shr-internal-width)
-		    (> shr-internal-width 0)
-		    (progn
-		      (setq found (shr-find-fill-point))
-		      (not (eolp))))
-	  (when (eq (preceding-char) ? )
-	    (delete-char -1))
-	  (insert "\n")
-	  (unless found
-	    ;; 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))
-	(if (<= (current-column) shr-internal-width)
-	    (insert " ")
-	  ;; In case we couldn't get a valid break point (because of a
-	  ;; word that's longer than `shr-internal-width'), just break anyway.
-	  (insert "\n")
-	  (when (> shr-indentation 0)
-	    (shr-indent)))))
-    (unless (string-match "[ \t\r\n ]\\'" text)
-      (delete-char -1)))))
-
-(defun shr-find-fill-point ()
-  (when (> (move-to-column shr-internal-width) shr-internal-width)
-    (backward-char 1))
+    (let ((start (point))
+	  (bolp (bolp)))
+      (insert text)
+      (save-restriction
+	(narrow-to-region start (point))
+	(goto-char start)
+	(when (looking-at "[ \t\n\r ]+")
+	  (replace-match "" t t))
+	(while (re-search-forward "[ \t\n\r ]+" nil t)
+	  (replace-match " " t t))
+	(goto-char (point-max)))
+      ;; We may have removed everything we inserted if if was just
+      ;; spaces.
+      (unless (= start (point))
+	;; Mark all lines that should possibly be folded afterwards.
+	(when bolp
+	  (shr-mark-fill start))
+	(when shr-use-fonts
+	  (add-face-text-property start (point)
+				  (or shr-current-font 'variable-pitch)
+				  t)))))))
+
+(defun shr-fill-lines (start end)
+  (if (<= shr-internal-width 0)
+      nil
+    (save-restriction
+      (narrow-to-region start end)
+      (goto-char start)
+      (when (get-text-property (point) 'shr-indentation)
+	(shr-fill-line))
+      (while (setq start (next-single-property-change start 'shr-indentation))
+	(goto-char start)
+	(when (bolp)
+	  (shr-fill-line)))
+      (goto-char (point-max)))))
+
+(defun shr-vertical-motion (column)
+  (if (not shr-use-fonts)
+      (move-to-column column)
+    (unless (eolp)
+      (forward-char 1))
+    (vertical-motion (cons (/ column (frame-char-width)) 0))
+    (unless (eolp)
+      (forward-char 1))))
+
+(defun shr-fill-line ()
+  (let ((shr-indentation (get-text-property (point) 'shr-indentation))
+	(continuation (get-text-property
+		       (point) 'shr-continuation-indentation))
+	start)
+    (put-text-property (point) (1+ (point)) 'shr-indentation nil)
+    (shr-indent)
+    (setq start (point))
+    (setq shr-indentation (or continuation shr-indentation))
+    (shr-vertical-motion shr-internal-width)
+    (when (looking-at " $")
+      (delete-region (point) (line-end-position)))
+    (while (not (eolp))
+      ;; We have to do some folding.  First find the first
+      ;; previous point suitable for folding.
+      (if (or (not (shr-find-fill-point (line-beginning-position)))
+	      (= (point) start))
+	  ;; We had unbreakable text (for this width), so just go to
+	  ;; the first space and carry on.
+	  (progn
+	    (beginning-of-line)
+	    (skip-chars-forward " ")
+	    (search-forward " " (line-end-position) 'move)))
+      ;; Success; continue.
+      (when (= (preceding-char) ?\s)
+	(delete-char -1))
+      (insert "\n")
+      (shr-indent)
+      (setq start (point))
+      (shr-vertical-motion shr-internal-width)
+      (when (looking-at " $")
+	(delete-region (point) (line-end-position))))))
+
+(defun shr-find-fill-point (start)
   (let ((bp (point))
+	(end (point))
 	failed)
-    (while (not (or (setq failed (<= (current-column) shr-indentation))
+    (while (not (or (setq failed (<= (point) start))
 		    (eq (preceding-char) ? )
 		    (eq (following-char) ? )
 		    (shr-char-breakable-p (preceding-char))
@@ -547,12 +611,12 @@ size, and full-buffer size."
 	 (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
 		     (shr-char-kinsoku-eol-p (preceding-char)))
 	   (backward-char 1))
-	 (when (setq failed (<= (current-column) shr-indentation))
+	 (when (setq failed (<= (point) start))
 	   ;; There's no breakable point that doesn't violate kinsoku,
 	   ;; so we look for the second best position.
 	   (while (and (progn
 			 (forward-char 1)
-			 (<= (current-column) shr-internal-width))
+			 (<= (point) end))
 		       (progn
 			 (setq bp (point))
 			 (shr-char-kinsoku-eol-p (following-char)))))
@@ -567,7 +631,7 @@ size, and full-buffer size."
 		      (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
 		      (or (shr-char-kinsoku-eol-p (preceding-char))
 			  (shr-char-kinsoku-bol-p (following-char)))))))
-	 (when (setq failed (<= (current-column) shr-indentation))
+	 (when (setq failed (<= (point) start))
 	   ;; There's no breakable point that doesn't violate kinsoku,
 	   ;; so we go to the second best position.
 	   (if (looking-at "\\(\\c<+\\)\\c<")
@@ -664,13 +728,18 @@ size, and full-buffer size."
 
 (defun shr-indent ()
   (when (> shr-indentation 0)
-    (insert (make-string shr-indentation ? ))))
+    (insert
+     (if (not shr-use-fonts)
+	 (make-string shr-indentation ?\s)
+       (propertize " "
+		   'display
+		   `(space :width (,shr-indentation)))))))
 
 (defun shr-fontize-dom (dom &rest types)
-  (let (shr-start)
+  (let ((start (point)))
     (shr-generic dom)
     (dolist (type types)
-      (shr-add-font (or shr-start (point)) (point) type))))
+      (shr-add-font start (point) type))))
 
 ;; Add face to the region, but avoid putting the font properties on
 ;; blank text at the start of the line, and the newline at the end, to
@@ -1070,13 +1139,11 @@ ones, in case fg and bg are nil."
 
 (defun shr-tag-p (dom)
   (shr-ensure-paragraph)
-  (shr-indent)
   (shr-generic dom)
   (shr-ensure-paragraph))
 
 (defun shr-tag-div (dom)
   (shr-ensure-newline)
-  (shr-indent)
   (shr-generic dom)
   (shr-ensure-newline))
 
@@ -1116,9 +1183,10 @@ ones, in case fg and bg are nil."
 		  (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
 	      (when (string-match " *!important\\'" value)
 		(setq value (substring value 0 (match-beginning 0))))
-	      (push (cons (intern name obarray)
-			  value)
-		    plist)))))
+	      (unless (equal value "inherit")
+		(push (cons (intern name obarray)
+			    value)
+		      plist))))))
       plist)))
 
 (defun shr-tag-base (dom)
@@ -1245,8 +1313,7 @@ The preference is a float determined from `shr-prefer-media-type'."
   (when (or url
 	    (and dom
 		 (> (length (dom-attr dom 'src)) 0)))
-    (when (and (> (current-column) 0)
-	       (not (eq shr-state 'image)))
+    (when (> (current-column) 0)
       (insert "\n"))
     (let ((alt (dom-attr dom 'alt))
 	  (url (shr-expand-url (or url (dom-attr dom 'src)))))
@@ -1276,10 +1343,9 @@ The preference is a float determined from `shr-prefer-media-type'."
 	      (and shr-blocked-images
 		   (string-match shr-blocked-images url)))
 	  (setq shr-start (point))
-	  (let ((shr-state 'space))
-	    (if (> (string-width alt) 8)
-		(shr-insert (truncate-string-to-width alt 8))
-	      (shr-insert alt))))
+	  (if (> (string-width alt) 8)
+	      (shr-insert (truncate-string-to-width alt 8))
+	    (shr-insert alt)))
 	 ((and (not shr-ignore-cache)
 	       (url-is-cached (shr-encode-url url)))
 	  (funcall shr-put-image-function (shr-get-image-data url) alt))
@@ -1301,22 +1367,24 @@ The preference is a float determined from `shr-prefer-media-type'."
 	  (put-text-property start (point) 'image-displayer
 			     (shr-image-displayer shr-content-function))
 	  (put-text-property start (point) 'help-echo
-			     (shr-fold-text (or (dom-attr dom 'title) alt))))
-	(setq shr-state 'image)))))
+			     (shr-fill-text
+			      (or (dom-attr dom 'title) alt))))))))
 
 (defun shr-tag-pre (dom)
-  (let ((shr-folding-mode 'none))
+  (let ((shr-folding-mode 'none)
+	(shr-current-font 'default))
     (shr-ensure-newline)
-    (shr-indent)
     (shr-generic dom)
     (shr-ensure-newline)))
 
 (defun shr-tag-blockquote (dom)
   (shr-ensure-paragraph)
-  (shr-indent)
-  (let ((shr-indentation (+ shr-indentation 4)))
-    (shr-generic dom))
-  (shr-ensure-paragraph))
+  (let ((start (point))
+	(shr-indentation (+ shr-indentation
+			    (* 4 shr-table-separator-pixel-width))))
+    (shr-generic dom)
+    (shr-ensure-paragraph)
+    (shr-mark-fill start)))
 
 (defun shr-tag-dl (dom)
   (shr-ensure-paragraph)
@@ -1330,7 +1398,8 @@ The preference is a float determined from `shr-prefer-media-type'."
 
 (defun shr-tag-dd (dom)
   (shr-ensure-newline)
-  (let ((shr-indentation (+ shr-indentation 4)))
+  (let ((shr-indentation (+ shr-indentation
+			    (* 4 shr-table-separator-pixel-width))))
     (shr-generic dom)))
 
 (defun shr-tag-ul (dom)
@@ -1347,16 +1416,26 @@ The preference is a float determined from `shr-prefer-media-type'."
 
 (defun shr-tag-li (dom)
   (shr-ensure-newline)
-  (shr-indent)
-  (let* ((bullet
-	  (if (numberp shr-list-mode)
-	      (prog1
-		  (format "%d " shr-list-mode)
-		(setq shr-list-mode (1+ shr-list-mode)))
-	    shr-bullet))
-	 (shr-indentation (+ shr-indentation (length bullet))))
-    (insert bullet)
-    (shr-generic dom)))
+  (let ((start (point)))
+    (let* ((bullet
+	    (if (numberp shr-list-mode)
+		(prog1
+		    (format "%d " shr-list-mode)
+		  (setq shr-list-mode (1+ shr-list-mode)))
+	      shr-bullet)))
+      (insert bullet)
+      (shr-mark-fill start)
+      (let ((shr-indentation (+ shr-indentation
+				(shr-string-pixel-width bullet))))
+	(put-text-property start (1+ start)
+			   'shr-continuation-indentation shr-indentation)
+	(shr-generic dom)))))
+
+(defun shr-mark-fill (start)
+  ;; We may not have inserted any text to fill.
+  (unless (= start (point))
+    (put-text-property start (1+ start)
+		       'shr-indentation shr-indentation)))
 
 (defun shr-tag-br (dom)
   (when (and (not (bobp))
@@ -1365,15 +1444,14 @@ The preference is a float determined from `shr-prefer-media-type'."
 	     (or (not (bolp))
 		 (and (> (- (point) 2) (point-min))
 		      (not (= (char-after (- (point) 2)) ?\n)))))
-    (insert "\n")
-    (shr-indent))
+    (insert "\n"))
   (shr-generic dom))
 
 (defun shr-tag-span (dom)
   (shr-generic dom))
 
 (defun shr-tag-h1 (dom)
-  (shr-heading dom 'bold 'underline))
+  (shr-heading dom '(variable-pitch (:height 1.3 :weight bold))))
 
 (defun shr-tag-h2 (dom)
   (shr-heading dom 'bold))
@@ -1392,7 +1470,8 @@ The preference is a float determined from `shr-prefer-media-type'."
 
 (defun shr-tag-hr (_dom)
   (shr-ensure-newline)
-  (insert (make-string shr-internal-width shr-hr-line) "\n"))
+  ;; FIXME: Should try to make a line of the required pixel size.
+  (insert (make-string (window-width) shr-hr-line) "\n"))
 
 (defun shr-tag-title (dom)
   (shr-heading dom 'bold 'underline))
@@ -1424,20 +1503,23 @@ The preference is a float determined from `shr-prefer-media-type'."
 	 (shr-kinsoku-shorten t)
 	 ;; Find all suggested widths.
 	 (columns (shr-column-specs dom))
-	 ;; Compute how many characters wide each TD should be.
+	 ;; Compute how many pixels wide each TD should be.
 	 (suggested-widths (shr-pro-rate-columns columns))
 	 ;; Do a "test rendering" to see how big each TD is (this can
 	 ;; be smaller (if there's little text) or bigger (if there's
 	 ;; unbreakable text).
-	 (sketch (shr-make-table dom suggested-widths))
-	 ;; Compute the "natural" width by setting each column to 500
-	 ;; characters and see how wide they really render.
-	 (natural (shr-make-table dom (make-vector (length columns) 500)))
+	 (elems (or (dom-attr dom 'shr-suggested-widths)
+		    (shr-make-table dom suggested-widths nil
+				    'shr-suggested-widths)))
+	 (sketch (loop for line in elems
+		       collect (mapcar #'car line)))
+	 (natural (loop for line in elems
+			collect (mapcar #'cdr line)))
 	 (sketch-widths (shr-table-widths sketch natural suggested-widths)))
     ;; This probably won't work very well.
     (when (> (+ (loop for width across sketch-widths
 		      summing (1+ width))
-		shr-indentation 1)
+		shr-indentation shr-table-separator-pixel-width)
 	     (frame-width))
       (setq truncate-lines t))
     ;; Then render the table again with these new "hard" widths.
@@ -1466,64 +1548,71 @@ The preference is a float determined from `shr-prefer-media-type'."
 	;; Try to output it anyway.
 	(shr-generic dom)
       ;; It's a real table, so render it.
-      (shr-tag-table-1
-       (nconc
-	(list 'table nil)
-	(if caption `((tr nil (td nil ,@caption))))
-	(cond (header
-	       (if footer
-		   ;; header + body + footer
-		   (if (= nheader nbody)
-		       (if (= nbody nfooter)
-			   `((tr nil (td nil (table nil
-						    (tbody nil ,@header
-							   ,@body ,@footer)))))
-			 (nconc `((tr nil (td nil (table nil
-							 (tbody nil ,@header
-								,@body)))))
-				(if (= nfooter 1)
-				    footer
-				  `((tr nil (td nil (table
-						     nil (tbody
-							  nil ,@footer))))))))
-		     (nconc `((tr nil (td nil (table nil (tbody
-							  nil ,@header)))))
-			    (if (= nbody nfooter)
-				`((tr nil (td nil (table
-						   nil (tbody nil ,@body
-							      ,@footer)))))
-			      (nconc `((tr nil (td nil (table
-							nil (tbody nil
+      (if (dom-attr dom 'shr-fixed-table)
+	  (shr-tag-table-1 dom)
+	;; Only fix up the table once.
+	(let ((table
+	       (nconc
+		(list 'table nil)
+		(if caption `((tr nil (td nil ,@caption))))
+		(cond
+		 (header
+		  (if footer
+		      ;; header + body + footer
+		      (if (= nheader nbody)
+			  (if (= nbody nfooter)
+			      `((tr nil (td nil (table nil
+						       (tbody nil ,@header
+							      ,@body ,@footer)))))
+			    (nconc `((tr nil (td nil (table nil
+							    (tbody nil ,@header
 								   ,@body)))))
-				     (if (= nfooter 1)
-					 footer
-				       `((tr nil (td nil (table
-							  nil
-							  (tbody
-							   nil
-							   ,@footer))))))))))
-		 ;; header + body
-		 (if (= nheader nbody)
-		     `((tr nil (td nil (table nil (tbody nil ,@header
-							 ,@body)))))
-		   (if (= nheader 1)
-		       `(,@header (tr nil (td nil (table
-						   nil (tbody nil ,@body)))))
-		     `((tr nil (td nil (table nil (tbody nil ,@header))))
-		       (tr nil (td nil (table nil (tbody nil ,@body)))))))))
-	      (footer
-	       ;; body + footer
-	       (if (= nbody nfooter)
-		   `((tr nil (td nil (table
-				      nil (tbody nil ,@body ,@footer)))))
-		 (nconc `((tr nil (td nil (table nil (tbody nil ,@body)))))
-			(if (= nfooter 1)
-			    footer
-			  `((tr nil (td nil (table
-					     nil (tbody nil ,@footer)))))))))
-	      (caption
-	       `((tr nil (td nil (table nil (tbody nil ,@body))))))
-	      (body)))))
+				   (if (= nfooter 1)
+				       footer
+				     `((tr nil (td nil (table
+							nil (tbody
+							     nil ,@footer))))))))
+			(nconc `((tr nil (td nil (table nil (tbody
+							     nil ,@header)))))
+			       (if (= nbody nfooter)
+				   `((tr nil (td nil (table
+						      nil (tbody nil ,@body
+								 ,@footer)))))
+				 (nconc `((tr nil (td nil (table
+							   nil (tbody nil
+								      ,@body)))))
+					(if (= nfooter 1)
+					    footer
+					  `((tr nil (td nil (table
+							     nil
+							     (tbody
+							      nil
+							      ,@footer))))))))))
+		    ;; header + body
+		    (if (= nheader nbody)
+			`((tr nil (td nil (table nil (tbody nil ,@header
+							    ,@body)))))
+		      (if (= nheader 1)
+			  `(,@header (tr nil (td nil (table
+						      nil (tbody nil ,@body)))))
+			`((tr nil (td nil (table nil (tbody nil ,@header))))
+			  (tr nil (td nil (table nil (tbody nil ,@body)))))))))
+		 (footer
+		  ;; body + footer
+		  (if (= nbody nfooter)
+		      `((tr nil (td nil (table
+					 nil (tbody nil ,@body ,@footer)))))
+		    (nconc `((tr nil (td nil (table nil (tbody nil ,@body)))))
+			   (if (= nfooter 1)
+			       footer
+			     `((tr nil (td nil (table
+						nil (tbody nil ,@footer)))))))))
+		 (caption
+		  `((tr nil (td nil (table nil (tbody nil ,@body))))))
+		 (body)))))
+	  (dom-set-attribute table 'shr-fixed-table t)
+	  (setcdr dom (cdr table))
+	  (shr-tag-table-1 dom))))
     (when bgcolor
       (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
 			   bgcolor))
@@ -1531,6 +1620,8 @@ The preference is a float determined from `shr-prefer-media-type'."
     ;; model isn't strong enough to allow us to put the images actually
     ;; into the tables.
     (when (zerop shr-table-depth)
+      (save-excursion
+	(shr-expand-alignments start (point)))
       (dolist (elem (dom-by-tag dom 'object))
 	(shr-tag-object elem))
       (dolist (elem (dom-by-tag dom 'img))
@@ -1540,38 +1631,87 @@ The preference is a float determined from `shr-prefer-media-type'."
   (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
 			  "collapse"))
 	 (shr-table-separator-length (if collapse 0 1))
-	 (shr-table-vertical-line (if collapse "" shr-table-vertical-line)))
+	 (shr-table-vertical-line (if collapse "" shr-table-vertical-line))
+	 (start (point)))
+    (setq shr-table-id (1+ shr-table-id))
     (unless collapse
       (shr-insert-table-ruler widths))
     (dolist (row table)
       (let ((start (point))
+	    (align 0)
+	    (column-number 0)
 	    (height (let ((max 0))
 		      (dolist (column row)
-			(setq max (max max (cadr column))))
+			(setq max (max max (nth 2 column))))
 		      max)))
-	(dotimes (i height)
+	(dotimes (i (max height 1))
 	  (shr-indent)
 	  (insert shr-table-vertical-line "\n"))
 	(dolist (column row)
-	  (goto-char start)
-	  (let ((lines (nth 2 column)))
-	    (dolist (line lines)
-	      (end-of-line)
-	      (insert line shr-table-vertical-line)
-	      (forward-line 1))
-	    ;; Add blank lines at padding at the bottom of the TD,
-	    ;; possibly.
-	    (dotimes (i (- height (length lines)))
-	      (end-of-line)
-	      (let ((start (point)))
-		(insert (make-string (string-width (car lines)) ? )
-			shr-table-vertical-line)
-		(when (nth 4 column)
-		  (shr-add-font start (1- (point))
-				(list :background (nth 4 column)))))
-	      (forward-line 1)))))
+	  (when (> (nth 2 column) -1)
+	    (goto-char start)
+	    ;; Sum up all the widths from the column.  (There may be
+	    ;; more than one if this is a "colspan" column.)
+	    (dotimes (i (nth 4 column))
+	      ;; The colspan directive may be wrong and there may not be
+	      ;; that number of columns.
+	      (when (<= column-number (1- (length widths)))
+		(setq align (+ align
+			       (aref widths column-number)
+			       (* 2 shr-table-separator-pixel-width))))
+	      (setq column-number (1+ column-number)))
+	    (let ((lines (nth 3 column))
+		  (pixel-align (if (not shr-use-fonts)
+				   (* align (frame-char-width))
+				 align)))
+	      (dolist (line lines)
+		(end-of-line)
+		(let ((start (point)))
+		  (insert line
+			  (propertize " "
+				      'display `(space :align-to (,pixel-align))
+				      'shr-table-indent shr-table-id)
+			  shr-table-vertical-line)
+		  (shr-colorize-region
+		   start (1- (point)) (nth 5 column) (nth 6 column)))
+		(forward-line 1))
+	      ;; Add blank lines at padding at the bottom of the TD,
+	      ;; possibly.
+	      (dotimes (i (- height (length lines)))
+		(end-of-line)
+		(let ((start (point)))
+		  (insert (propertize " "
+				      'display `(space :align-to (,pixel-align))
+				      'shr-table-indent shr-table-id)
+			  shr-table-vertical-line)
+		  (shr-colorize-region
+		   start (1- (point)) (nth 5 column) (nth 6 column)))
+		(forward-line 1))))))
       (unless collapse
-	(shr-insert-table-ruler widths)))))
+	(shr-insert-table-ruler widths)))
+    (unless (= start (point))
+      (put-text-property start (1+ start) 'shr-table-id shr-table-id))))
+
+(defun shr-expand-alignments (start end)
+  (while (< (setq start (next-single-property-change
+			 start 'shr-table-id nil end))
+	    end)
+    (goto-char start)
+    (let* ((shr-use-fonts t)
+	   (id (get-text-property (point) 'shr-table-id))
+	   (base (shr-pixel-column))
+	   elem)
+      (when id
+	(save-excursion
+	  (while (setq elem (text-property-any
+			     (point) end 'shr-table-indent id))
+	    (goto-char elem)
+	    (let ((align (get-text-property (point) 'display)))
+	      (put-text-property (point) (1+ (point)) 'display
+				 `(space :align-to (,(+ (car (nth 2 align))
+							base)))))
+	    (forward-char 1)))))
+    (setq start (1+ start))))
 
 (defun shr-insert-table-ruler (widths)
   (when shr-table-horizontal-line
@@ -1579,9 +1719,17 @@ The preference is a float determined from `shr-prefer-media-type'."
 	       (> 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))
+    (let ((total-width 0))
+      (dotimes (i (length widths))
+	(setq total-width (+ total-width (aref widths i)
+			     (* shr-table-separator-pixel-width 2)))
+	(insert (make-string (1+ (/ (aref widths i)
+				    shr-table-separator-pixel-width))
+			     shr-table-horizontal-line)
+		(propertize " "
+			    'display `(space :align-to (,total-width))
+			    'shr-table-indent shr-table-id)
+		shr-table-corner)))
     (insert "\n")))
 
 (defun shr-table-widths (table natural-table suggested-widths)
@@ -1599,7 +1747,8 @@ The preference is a float determined from `shr-prefer-media-type'."
 	  (aset natural-widths i (max (aref natural-widths i) column))
 	  (setq i (1+ i)))))
     (let ((extra (- (apply '+ (append suggested-widths nil))
-		    (apply '+ (append widths nil))))
+		    (apply '+ (append widths nil))
+		    (* shr-table-separator-pixel-width (length widths))))
 	  (expanded-columns 0))
       ;; We have extra, unused space, so divide this space amongst the
       ;; columns.
@@ -1617,11 +1766,13 @@ The preference is a float determined from `shr-prefer-media-type'."
 			       (aref widths i))))))))
     widths))
 
-(defun shr-make-table (dom widths &optional fill)
+(defun shr-make-table (dom widths &optional fill storage-attribute)
   (or (cadr (assoc (list dom widths fill) shr-content-cache))
       (let ((data (shr-make-table-1 dom widths fill)))
 	(push (list (list dom widths fill) data)
 	      shr-content-cache)
+	(when storage-attribute
+	  (dom-set-attribute dom storage-attribute data))
 	data)))
 
 (defun shr-make-table-1 (dom widths &optional fill)
@@ -1634,7 +1785,7 @@ The preference is a float determined from `shr-prefer-media-type'."
     (dolist (row (dom-non-text-children dom))
       (when (eq (dom-tag row) 'tr)
 	(let ((tds nil)
-	      (columns (dom-children row))
+	      (columns (dom-non-text-children row))
 	      (i 0)
 	      (width-column 0)
 	      column)
@@ -1660,7 +1811,7 @@ The preference is a float determined from `shr-prefer-media-type'."
 	      (setq width
 		    (if column
 			(aref widths width-column)
-		      10))
+		      (* 10 shr-table-separator-pixel-width)))
 	      (when (setq colspan (dom-attr column 'colspan))
 		(setq colspan (min (string-to-number colspan)
 				   ;; The colspan may be wrong, so
@@ -1682,35 +1833,80 @@ The preference is a float determined from `shr-prefer-media-type'."
 		(setq width-column (+ width-column (1- colspan))
 		      colspan-count colspan
 		      colspan-remaining colspan))
-	      (when (or column
-			(not fill))
+	      (when column
 		(let ((data (shr-render-td column width fill)))
 		  (if (and (not fill)
 			   (> colspan-remaining 0))
 		      (progn
-			(when (= colspan-count colspan-remaining)
-			  (setq colspan-width data))
+			(setq colspan-width (car data))
 			(let ((this-width (/ colspan-width colspan-count)))
-			  (push this-width tds)
+			  (push (cons this-width (cadr data)) tds)
 			  (setq colspan-remaining (1- colspan-remaining))))
-		    (push data tds))))
+		    (if (not fill)
+			(push (cons (car data) (cadr data)) tds)
+		      (push data tds)))))
+	      (when (and colspan
+			 (> colspan 1))
+		(dotimes (c (1- colspan))
+		  (setq i (1+ i))
+		  (push
+		   (if fill
+		       (list 0 0 -1 nil 1 nil nil)
+		     '(0 . 0))
+		   tds)))
 	      (setq i (1+ i)
 		    width-column (1+ width-column))))
 	  (push (nreverse tds) trs))))
     (nreverse trs)))
 
+(defun shr-pixel-buffer-width ()
+  (if (not shr-use-fonts)
+      (save-excursion
+	(goto-char (point-min))
+	(let ((max 0))
+	  (while (not (eobp))
+	    (end-of-line)
+	    (setq max (max max (current-column)))
+	    (forward-line 1))
+	  max))
+    (if (get-buffer-window)
+	(car (window-text-pixel-size nil (point-min) (point-max)))
+      (save-window-excursion
+	(set-window-buffer nil (current-buffer))
+	(car (window-text-pixel-size nil (point-min) (point-max)))))))
+
 (defun shr-render-td (dom width fill)
+  (let ((cache (intern (format "shr-td-cache-%s-%s" width fill))))
+    (or (dom-attr dom cache)
+	(and fill
+	     (let (result)
+	       (dolist (attr (dom-attributes dom))
+		 (let ((name (symbol-name (car attr))))
+		   (when (string-match "shr-td-cache-\\([0-9]+\\)-nil" name)
+		     (let ((cache-width (string-to-number
+					 (match-string 1 name))))
+		       (when (and (>= cache-width width)
+				  (<= (car (cdr attr)) width))
+			 (setq result (cdr attr)))))))
+	       result))
+	(let ((result (shr-render-td-1 dom width fill)))
+	  (dom-set-attribute dom cache result)
+	  result))))
+
+(defun shr-render-td-1 (dom width fill)
   (with-temp-buffer
     (let ((bgcolor (dom-attr dom 'bgcolor))
 	  (fgcolor (dom-attr dom 'fgcolor))
 	  (style (dom-attr dom 'style))
 	  (shr-stylesheet shr-stylesheet)
-	  actual-colors)
+	  (max-width 0)
+	  natural-width)
       (when style
 	(setq style (and (string-match "color" style)
 			 (shr-parse-style style))))
       (when bgcolor
-	(setq style (nconc (list (cons 'background-color bgcolor)) style)))
+	(setq style (nconc (list (cons 'background-color bgcolor))
+			   style)))
       (when fgcolor
 	(setq style (nconc (list (cons 'color fgcolor)) style)))
       (when style
@@ -1718,6 +1914,22 @@ The preference is a float determined from `shr-prefer-media-type'."
       (let ((shr-internal-width width)
 	    (shr-indentation 0))
 	(shr-descend dom))
+      (save-window-excursion
+	(set-window-buffer nil (current-buffer))
+	(unless fill
+	  (setq natural-width
+		(or (dom-attr dom 'shr-td-cache-natural)
+		    (let ((natural (max (shr-pixel-buffer-width)
+					(shr-dom-max-natural-width dom 0))))
+		      (dom-set-attribute dom 'shr-td-cache-natural natural)
+		      natural))))
+	(if (and natural-width
+		 (<= natural-width width))
+	    (setq max-width natural-width)
+	  (let ((shr-internal-width width))
+	    (shr-fill-lines (point-min) (point-max))
+	    (setq max-width (shr-pixel-buffer-width)))))
+      (goto-char (point-max))
       ;; Delete padding at the bottom of the TDs.
       (delete-region
        (point)
@@ -1726,48 +1938,31 @@ The preference is a float determined from `shr-prefer-media-type'."
 	 (end-of-line)
 	 (point)))
       (goto-char (point-min))
-      (let ((max 0))
-	(while (not (eobp))
-	  (end-of-line)
-	  (setq max (max max (current-column)))
-	  (forward-line 1))
-	(when fill
-	  (goto-char (point-min))
-	  ;; If the buffer is totally empty, then put a single blank
-	  ;; line here.
-	  (if (zerop (buffer-size))
-	      (insert (make-string width ? ))
-	    ;; Otherwise, fill the buffer.
-	    (let ((align (dom-attr dom 'align))
-		  length)
-	      (while (not (eobp))
-		(end-of-line)
-		(setq length (- width (current-column)))
-		(when (> length 0)
-		  (cond
-		   ((equal align "right")
-		    (beginning-of-line)
-		    (insert (make-string length ? )))
-		   ((equal align "center")
-		    (insert (make-string (/ length 2) ? ))
-		    (beginning-of-line)
-		    (insert (make-string (- length (/ length 2)) ? )))
-		   (t
-		    (insert (make-string length ? )))))
-		(forward-line 1))))
-	  (when style
-	    (setq actual-colors
-		  (shr-colorize-region
-		   (point-min) (point-max)
-		   (cdr (assq 'color shr-stylesheet))
-		   (cdr (assq 'background-color shr-stylesheet))))))
-	(if fill
-	    (list max
-		  (count-lines (point-min) (point-max))
-		  (split-string (buffer-string) "\n")
-		  nil
-		  (car actual-colors))
-	  max)))))
+      (list max-width
+	    natural-width
+	    (count-lines (point-min) (point-max))
+	    (split-string (buffer-string) "\n")
+	    (if (dom-attr dom 'colspan)
+		(string-to-number (dom-attr dom 'colspan))
+	      1)
+	    (cdr (assq 'color shr-stylesheet))
+	    (cdr (assq 'background-color shr-stylesheet))))))
+
+(defun shr-dom-max-natural-width (dom max)
+  (if (eq (dom-tag dom) 'table)
+      (max max (or
+		(loop for line in (dom-attr dom 'shr-suggested-widths)
+		      maximize (+
+				shr-table-separator-length
+				(loop for elem in line
+				      summing
+				      (+ (cdr elem)
+					 (* 2 shr-table-separator-length)))))
+		0))
+    (dolist (child (dom-children dom))
+      (unless (stringp child)
+	(setq max (max (shr-dom-max-natural-width child max)))))
+    max))
 
 (defun shr-buffer-width ()
   (goto-char (point-min))
@@ -1788,7 +1983,8 @@ The preference is a float determined from `shr-prefer-media-type'."
       (aset widths i (max (truncate (* (aref columns i)
 				       total-percentage
 				       (- shr-internal-width
-                                          (1+ (length columns)))))
+                                          (* (1+ (length columns))
+					     shr-table-separator-pixel-width))))
 			  10)))
     widths))
 
@@ -1798,9 +1994,8 @@ The preference is a float determined from `shr-prefer-media-type'."
     (dolist (row (dom-non-text-children dom))
       (when (eq (dom-tag row) 'tr)
 	(let ((i 0))
-	  (dolist (column (dom-children row))
-	    (when (and (not (stringp column))
-		       (memq (dom-tag column) '(td th)))
+	  (dolist (column (dom-non-text-children row))
+	    (when (memq (dom-tag column) '(td th))
 	      (let ((width (dom-attr column 'width)))
 		(when (and width
 			   (string-match "\\([0-9]+\\)%" width)