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)