htmlfontify.el 98.4 KB
Newer Older
Paul Eggert's avatar
Paul Eggert committed
1
;;; htmlfontify.el --- htmlize a buffer/source tree with optional hyperlinks
Stefan Monnier's avatar
Stefan Monnier committed
2

3
;; Copyright (C) 2002-2003, 2009-2012  Free Software Foundation, Inc.
Stefan Monnier's avatar
Stefan Monnier committed
4 5 6 7 8 9 10 11 12

;; Emacs Lisp Archive Entry
;; Package: htmlfontify
;; Filename: htmlfontify.el
;; Version: 0.21
;; Keywords: html, hypermedia, markup, etags
;; Author: Vivek Dasmohapatra <vivek@etla.org>
;; Maintainer: Vivek Dasmohapatra <vivek@etla.org>
;; Created: 2002-01-05
Paul Eggert's avatar
Paul Eggert committed
13
;; Description: htmlize a buffer/source tree with optional hyperlinks
Stefan Monnier's avatar
Stefan Monnier committed
14 15 16 17
;; URL: http://rtfm.etla.org/emacs/htmlfontify/
;; Compatibility: Emacs23, Emacs22
;; Incompatibility: Emacs19, Emacs20, Emacs21
;; Last Updated: Thu 2009-11-19 01:31:21 +0000
18
;; Version: 0.21
Stefan Monnier's avatar
Stefan Monnier committed
19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; I have made some changes to make it work for Emacs 22.   A lot of
;; small bug fixes related to the format of text and overlay
;; properties (which might have changed since the beginning of 2003
;; when this file was originally written).
;;
;; The function `hfy-face-at' currently carries much of the burden of
;; my lacking understanding of the formats mentioned above and should
;; need some knowledgeable help.
;;
;; Another thing that maybe could be fixed is that overlay background
;; colors which are now only seen where there is text (in the XHTML
;; output).  A bit of CSS tweaking is necessary there.
;;
;; The face 'default has a value :background "SystemWindow" for the
;; background color.   There is no explicit notion that this should be
;; considered transparent, but I have assumed that it could be handled
;; like if it was here.  (I am unsure that background and foreground
;; priorities are handled ok, but it looks ok in my tests now.)
;;
;; 2007-12-27 Lennart Borgman
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Here's some elisp code to html-pretty-print an Emacs buffer, preserving
;; the Emacs syntax/whatever highlighting.  It also knows how to drive etags
;; (exuberant-ctags or Emacs etags) and hyperlink the code according
;; to its (etags') output.

;; NOTE: Currently the hyperlinking code only knows how to drive GNU find
;; and the exuberant and GNU variants of etags : I do not know of any other
;; etags variants, but mechanisms have been provided to allow htmlfontify
;; to be taught how to drive them.  As long as your version of find has
;; the -path test and is reasonably sane, you should be fine.

;; A sample of the htmlfontified / hyperlinked output of this module can be
;; found at http://rtfm.etla.org/sql/dbishell/src/ - it's not perfect, but
;; it's a hell of a lot faster and more thorough than I could hope to be
;; doing this by hand.

;; some user / horrified onlooker comments:
;; What? No! There's something deeply wrong here...   (R. Shufflebotham)
;; You're a freak.                                    (D. Silverstone)
;; Aren't we giving you enough to do?                 (J. Busuttil)
;; You're almost as messed up as Lexx is!             (N. Graves-Morris)

;;; History:
;; Changes: moved to changelog (CHANGES) file.

;;; Code:
(eval-when-compile (require 'cl))
(require 'faces)
;;  (`facep' `face-attr-construct' `x-color-values' `color-values' `face-name')
(require 'custom)
;;  (`defgroup' `defcustom')
(require 'font-lock)
;;  (`font-lock-fontify-region')
(require 'cus-edit)

(defconst htmlfontify-version 0.21)

(defconst hfy-meta-tags
  (format "<meta name=\"generator\" content=\"emacs %s; htmlfontify %0.2f\" />"
          emacs-version htmlfontify-version)
  "The generator meta tag for this version of htmlfontify.")

(defconst htmlfontify-manual "Htmlfontify Manual"
102 103
  "Copy and convert buffers and files to HTML, adding hyperlinks between files
\(driven by etags) if requested.
Stefan Monnier's avatar
Stefan Monnier committed
104 105 106 107 108 109 110
\nInteractive functions:
  `htmlfontify-buffer'
  `htmlfontify-run-etags'
  `htmlfontify-copy-and-link-dir'
  `htmlfontify-load-rgb-file'
  `htmlfontify-unload-rgb-file'\n
In order to:\n
111 112 113
fontify a file you have open:           \\[htmlfontify-buffer]
prepare the etags map for a directory:  \\[htmlfontify-run-etags]
copy a directory, fontifying as you go: \\[htmlfontify-copy-and-link-dir]\n
Stefan Monnier's avatar
Stefan Monnier committed
114
The following might be useful when running non-windowed or in batch mode:
115
\(note that they shouldn't be necessary - we have a built in map)\n
116 117
load an X11 style rgb.txt file:         \\[htmlfontify-load-rgb-file]
unload the current rgb.txt file:        \\[htmlfontify-unload-rgb-file]\n
Stefan Monnier's avatar
Stefan Monnier committed
118
And here's a programmatic example:\n
119 120
\(defun rtfm-build-page-header (file style)
  (format \"#define  TEMPLATE red+black.html
Stefan Monnier's avatar
Stefan Monnier committed
121 122 123
#define  DEBUG    1
#include <build/menu-dirlist|>\\n
html-css-url := /css/red+black.css
124
title        := rtfm.etla.org ( %s / src/%s )
Stefan Monnier's avatar
Stefan Monnier committed
125 126 127 128 129
bodytag      :=
head         <=STYLESHEET;\\n
%s
STYLESHEET
main-title   := rtfm / %s / src/%s\\n
130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file))

\(defun rtfm-build-page-footer (file) \"\\nMAIN_CONTENT\\n\")

\(defun rtfm-build-source-docs (section srcdir destdir)
  (interactive
   \"s section[eg- emacs / p4-blame]:\\nD source-dir: \\nD output-dir: \")
  (require 'htmlfontify)
  (hfy-load-tags-cache srcdir)
  (let ((hfy-page-header  'rtfm-build-page-header)
        (hfy-page-footer  'rtfm-build-page-footer)
        (rtfm-section                     section)
        (hfy-index-file                   \"index\"))
    (htmlfontify-run-etags srcdir)
    (htmlfontify-copy-and-link-dir srcdir destdir \".src\" \".html\")))")
Stefan Monnier's avatar
Stefan Monnier committed
145 146

(defgroup htmlfontify nil
Chong Yidong's avatar
Chong Yidong committed
147
  "Convert buffers and files to HTML."
Stefan Monnier's avatar
Stefan Monnier committed
148
  :group  'applications
Chong Yidong's avatar
Chong Yidong committed
149
  :link '(variable-link htmlfontify-manual)
Stefan Monnier's avatar
Stefan Monnier committed
150 151 152
  :prefix "hfy-")

(defcustom hfy-page-header 'hfy-default-header
Juanma Barranquero's avatar
Juanma Barranquero committed
153
  "Function called to build the header of the HTML source.
154
This is called with two arguments (the filename relative to the top
155
level source directory being etag'd and fontified), and a string containing
156
the <style>...</style> text to embed in the document.
Juanma Barranquero's avatar
Juanma Barranquero committed
157
It should return a string that will be used as the header for the
158
htmlfontified version of the source file.\n
159
See also `hfy-page-footer'."
Stefan Monnier's avatar
Stefan Monnier committed
160
  :group 'htmlfontify
161 162
  ;; FIXME: Why place such a :tag everywhere?  Isn't it imposing your
  ;; own Custom preference on your users?  --Stef
Stefan Monnier's avatar
Stefan Monnier committed
163 164 165 166
  :tag   "page-header"
  :type  '(function))

(defcustom hfy-split-index nil
167 168
  "Whether or not to split the index `hfy-index-file' alphabetically.
If non-nil, the index is split on the first letter of each tag.
Juanma Barranquero's avatar
Juanma Barranquero committed
169 170
Useful when the index would otherwise be large and take
a long time to render or be difficult to navigate."
Stefan Monnier's avatar
Stefan Monnier committed
171 172 173 174 175
  :group 'htmlfontify
  :tag   "split-index"
  :type  '(boolean))

(defcustom hfy-page-footer 'hfy-default-footer
176 177
  "As `hfy-page-header', but generates the output footer.
It takes only one argument, the filename."
Stefan Monnier's avatar
Stefan Monnier committed
178 179 180 181
  :group 'htmlfontify
  :tag   "page-footer"
  :type  '(function))

Juanma Barranquero's avatar
Juanma Barranquero committed
182
(defcustom hfy-extn ".html"
183
  "File extension used for output files."
Stefan Monnier's avatar
Stefan Monnier committed
184 185 186 187 188
  :group 'htmlfontify
  :tag   "extension"
  :type  '(string))

(defcustom hfy-src-doc-link-style "text-decoration: underline;"
189
  "String to add to the '<style> a' variant of an htmlfontify CSS class."
Stefan Monnier's avatar
Stefan Monnier committed
190 191 192 193 194
  :group 'htmlfontify
  :tag   "src-doc-link-style"
  :type  '(string))

(defcustom hfy-src-doc-link-unstyle " text-decoration: none;"
195
  "Regex to remove from the <style> a variant of an htmlfontify CSS class."
Stefan Monnier's avatar
Stefan Monnier committed
196 197 198 199 200
  :group 'htmlfontify
  :tag   "src-doc-link-unstyle"
  :type  '(string))

(defcustom hfy-link-extn nil
201 202 203 204
  "File extension used for href links.
Useful where the htmlfontify output files are going to be processed
again, with a resulting change in file extension.  If nil, then any
code using this should fall back to `hfy-extn'."
Stefan Monnier's avatar
Stefan Monnier committed
205 206 207 208 209
  :group 'htmlfontify
  :tag   "link-extension"
  :type  '(choice string (const nil)))

(defcustom hfy-link-style-fun 'hfy-link-style-string
210 211
  "Function to customize the appearance of hyperlinks.
Set this to a function, which will be called with one argument
212
\(a \"{ foo: bar; ...}\" CSS style-string) - it should return a copy of
Stefan Monnier's avatar
Stefan Monnier committed
213 214 215 216 217 218 219
its argument, altered so as to make any changes you want made for text which
is a hyperlink, in addition to being in the class to which that style would
normally be applied."
  :group 'htmlfontify
  :tag   "link-style-function"
  :type  '(function))

220 221
(defcustom hfy-index-file "hfy-index"
  "Name (sans extension) of the tag definition index file produced during
Stefan Monnier's avatar
Stefan Monnier committed
222 223 224 225 226
fontification-and-hyperlinking."
  :group 'htmlfontify
  :tag   "index-file"
  :type  '(string))

227 228
(defcustom hfy-instance-file "hfy-instance"
  "Name (sans extension) of the tag usage index file produced during
Stefan Monnier's avatar
Stefan Monnier committed
229 230 231 232 233
fontification-and-hyperlinking."
  :group 'htmlfontify
  :tag   "instance-file"
  :type  '(string))

234
(defcustom hfy-html-quote-regex "\\([<\"&>]\\)"
235 236
  "Regex to match (with a single back-reference per match) strings in HTML
which should be quoted with `hfy-html-quote' (and `hfy-html-quote-map')
Stefan Monnier's avatar
Stefan Monnier committed
237 238 239 240 241
to make them safe."
  :group 'htmlfontify
  :tag   "html-quote-regex"
  :type  '(regexp))

242 243 244
(define-obsolete-variable-alias 'hfy-init-kludge-hooks 'hfy-init-kludge-hook
  "23.2")
(defcustom hfy-init-kludge-hook '(hfy-kludge-cperl-mode)
245 246
  "List of functions to call when starting `htmlfontify-buffer' to do any
kludging necessary to get highlighting modes to behave as you want, even
Stefan Monnier's avatar
Stefan Monnier committed
247 248 249 250 251 252
when not running under a window system."
  :group 'htmlfontify
  :tag   "init-kludge-hooks"
  :type  '(hook))

(defcustom hfy-post-html-hooks nil
253
  "List of functions to call after creating and filling the HTML buffer.
Juanma Barranquero's avatar
Juanma Barranquero committed
254
These functions will be called with the HTML buffer as the current buffer."
Stefan Monnier's avatar
Stefan Monnier committed
255 256 257 258 259 260
  :group   'htmlfontify
  :tag     "post-html-hooks"
  :options '(set-auto-mode)
  :type    '(hook))

(defcustom hfy-default-face-def nil
261 262 263 264 265 266
  "Fallback `defface' specification for the face 'default, used when
`hfy-display-class' has been set (the normal htmlfontify way of extracting
potentially non-current face information doesn't necessarily work for
'default).\n
Example: I customize this to:\n
\((t :background \"black\" :foreground \"white\" :family \"misc-fixed\"))"
Stefan Monnier's avatar
Stefan Monnier committed
267 268 269 270 271 272 273 274 275
  :group   'htmlfontify
  :tag     "default-face-definition"
  :type    '(alist))

(defcustom hfy-etag-regex (concat ".*"
                                  "\x7f" "\\([^\x01\n]+\\)"
                                  "\x01" "\\([0-9]+\\)"
                                  ","    "\\([0-9]+\\)$"
                                  "\\|"  ".*\x7f[0-9]+,[0-9]+$")
276
  "Regex used to parse an etags entry: must have 3 subexps, corresponding,
Stefan Monnier's avatar
Stefan Monnier committed
277 278 279
in order, to:\n
   1 - The tag
   2 - The line
280
   3 - The char (point) at which the tag occurs."
Stefan Monnier's avatar
Stefan Monnier committed
281 282 283 284 285 286 287 288
  :group 'htmlfontify
  :tag   "etag-regex"
  :type  '(regexp))

(defcustom hfy-html-quote-map '(("\"" "&quot;")
                                ("<"  "&lt;"  )
                                ("&"  "&amp;" )
                                (">"  "&gt;"  ))
289
  "Alist of char -> entity mappings used to make the text HTML-safe."
Stefan Monnier's avatar
Stefan Monnier committed
290 291 292
  :group 'htmlfontify
  :tag   "html-quote-map"
  :type  '(alist :key-type (string)))
293
(defconst hfy-e2x-etags-cmd "for src in `find . -type f`;
Stefan Monnier's avatar
Stefan Monnier committed
294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323
do
  ETAGS=%s;
  case ${src} in
    *.ad[absm]|*.[CFHMSacfhlmpsty]|*.def|*.in[cs]|*.s[as]|*.src|*.cc|\\
    *.hh|*.[chy]++|*.[ch]pp|*.[chy]xx|*.pdb|*.[ch]s|*.[Cc][Oo][Bb]|\\
    *.[eh]rl|*.f90|*.for|*.java|*.[cem]l|*.clisp|*.lisp|*.[Ll][Ss][Pp]|\\
    [Mm]akefile*|*.pas|*.[Pp][LlMm]|*.psw|*.lm|*.pc|*.prolog|*.oak|\\
    *.p[sy]|*.sch|*.scheme|*.[Ss][Cc][Mm]|*.[Ss][Mm]|*.bib|*.cl[os]|\\
    *.ltx|*.sty|*.TeX|*.tex|*.texi|*.texinfo|*.txi|*.x[bp]m|*.yy|\\
    *.[Ss][Qq][Ll])
          ${ETAGS} -o- ${src};
          ;;
      *)
          FTYPE=`file ${src}`;
          case ${FTYPE} in
              *script*text*)
                  ${ETAGS} -o- ${src};
                  ;;
              *text*)
                  SHEBANG=`head -n1 ${src} | grep '#!' -c`;
                  if [ ${SHEBANG} -eq 1 ];
                  then
                      ${ETAGS} -o- ${src};
                  fi;
                  ;;
          esac;
          ;;
  esac;
done;")

324 325 326
(defconst hfy-etags-cmd-alist-default
  `(("emacs etags"     . ,hfy-e2x-etags-cmd)
    ("exuberant ctags" . "%s -R -f -"   )))
Stefan Monnier's avatar
Stefan Monnier committed
327

328 329 330
(defcustom hfy-etags-cmd-alist
  hfy-etags-cmd-alist-default
  "Alist of possible shell commands that will generate etags output that
331
`htmlfontify' can use.  '%s' will be replaced by `hfy-etags-bin'."
332 333 334
  :group 'htmlfontify
  :tag   "etags-cmd-alist"
  :type  '(alist :key-type (string) :value-type (string)))
Stefan Monnier's avatar
Stefan Monnier committed
335 336

(defcustom hfy-etags-bin "etags"
337
  "Location of etags binary (we begin by assuming it's in your path).\n
Stefan Monnier's avatar
Stefan Monnier committed
338 339 340 341 342 343 344
Note that if etags is not in your path, you will need to alter the shell
commands in `hfy-etags-cmd-alist'."
  :group 'htmlfontify
  :tag   "etags-bin"
  :type  '(file))

(defcustom hfy-shell-file-name "/bin/sh"
Juanma Barranquero's avatar
Juanma Barranquero committed
345
  "Shell (Bourne or compatible) to invoke for complex shell operations."
Stefan Monnier's avatar
Stefan Monnier committed
346 347 348 349
  :group 'htmlfontify
  :tag   "shell-file-name"
  :type  '(file))

350
(defcustom hfy-ignored-properties '(read-only
351 352 353 354 355 356
                                    intangible
                                    modification-hooks
                                    insert-in-front-hooks
                                    insert-behind-hooks
                                    point-entered
                                    point-left)
357
  "Properties to omit when copying a fontified buffer for HTML transformation."
358 359 360 361
  :group 'htmlfontify
  :tag   "ignored-properties"
  :type '(repeat symbol))

Stefan Monnier's avatar
Stefan Monnier committed
362
(defun hfy-which-etags ()
Paul Eggert's avatar
Paul Eggert committed
363
  "Return a string indicating which flavor of etags we are using."
Stefan Monnier's avatar
Stefan Monnier committed
364 365 366 367 368
  (let ((v (shell-command-to-string (concat hfy-etags-bin " --version"))))
    (cond ((string-match "exube" v) "exuberant ctags")
          ((string-match "GNU E" v) "emacs etags"    )) ))

(defcustom hfy-etags-cmd
369 370 371 372 373 374 375
  ;; We used to wrap this in a `eval-and-compile', but:
  ;; - it had no effect because this expression was not seen by the
  ;;   byte-compiler (defcustom used to quote this argument).
  ;; - it signals an error (`hfy-which-etags' is not defined at compile-time).
  ;; - we want this auto-detection to reflect the system on which Emacs is run
  ;;   rather than the one on which it's compiled.
  (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist))
376
  "The etags equivalent command to run in a source directory to generate a tags
Stefan Monnier's avatar
Stefan Monnier committed
377 378
file for the whole source tree from there on down.  The command should emit
the etags output on stdout.\n
379 380
Two canned commands are provided - they drive Emacs' etags and
exuberant-ctags' etags respectively."
Stefan Monnier's avatar
Stefan Monnier committed
381 382
  :group 'htmlfontify
  :tag   "etags-command"
383 384 385 386
  :type (let ((clist (list '(string))))
          (dolist (C hfy-etags-cmd-alist)
            (push (list 'const :tag (car C) (cdr C)) clist))
          (cons 'choice clist)))
Stefan Monnier's avatar
Stefan Monnier committed
387 388

(defcustom hfy-istext-command "file %s | sed -e 's@^[^:]*:[ \t]*@@'"
389
  "Command to run with the name of a file, to see whether it is a text file
390 391
or not.  The command should emit a string containing the word 'text' if
the file is a text file, and a string not containing 'text' otherwise."
Stefan Monnier's avatar
Stefan Monnier committed
392 393 394 395 396 397
  :group 'htmlfontify
  :tag   "istext-command"
  :type  '(string))

(defcustom hfy-find-cmd
  "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*"
398
  "Find command used to harvest a list of files to attempt to fontify."
Stefan Monnier's avatar
Stefan Monnier committed
399 400 401 402 403
  :group 'htmlfontify
  :tag   "find-command"
  :type  '(string))

(defcustom hfy-display-class nil
404
  "Display class to use to determine which display class to use when
405
calculating a face's attributes.  This is useful when, for example, you
Stefan Monnier's avatar
Stefan Monnier committed
406 407 408
are running Emacs on a tty or in batch mode, and want htmlfontify to have
access to the face spec you would use if you were connected to an X display.\n
Some valid class specification elements are:\n
409 410 411 412 413 414 415 416
  '(class      color)
  '(class      grayscale)
  '(background dark)
  '(background light)
  '(type       x-toolkit)
  '(type       tty)
  '(type       motif)
  '(type       lucid)
Stefan Monnier's avatar
Stefan Monnier committed
417 418
Multiple values for a tag may be combined, to indicate that any one or more
of these values in the specification key constitutes a match, eg:\n
419 420 421 422 423 424 425
'((class color grayscale) (type tty)) would match any of:\n
  '((class color))
  '((class grayscale))
  '((class color grayscale))
  '((class color foo))
  '((type  tty))
  '((type  tty) (class color))\n
Stefan Monnier's avatar
Stefan Monnier committed
426 427 428 429 430 431 432 433 434
and so on."
  :type    '(alist :key-type (symbol) :value-type (symbol))
  :group   'htmlfontify
  :tag     "display-class"
  :options '((type       (choice (const :tag "X11"           x-toolkit)
                                 (const :tag "Terminal"      tty      )
                                 (const :tag "Lucid Toolkit" lucid    )
                                 (const :tag "Motif Toolkit" motif    )))

Paul Eggert's avatar
Paul Eggert committed
435 436
             (class      (choice (const :tag "Color"         color    )
                                 (const :tag "Grayscale"     grayscale)))
Stefan Monnier's avatar
Stefan Monnier committed
437 438 439 440 441

             (background (choice (const :tag "Dark"          dark     )
                                 (const :tag "Bright"        light    ))) ))

(defcustom hfy-optimisations (list 'keep-overlays)
442
  "Optimizations to turn on: So far, the following have been implemented:\n
Stefan Monnier's avatar
Stefan Monnier committed
443 444 445 446 447 448 449
  merge-adjacent-tags: If two (or more) span tags are adjacent, identical and
                       separated by nothing more than whitespace, they will
                       be merged into one span.
  zap-comment-links  : Suppress hyperlinking of tags found in comments.
  zap-string-links   : Suppress hyperlinking of tags found in strings.
  div-wrapper        : Add <div class=\"default\"> </div> tags around the
                       output.
450 451 452
  keep-overlays      : More of a bell (or possibly whistle) than an
                       optimization - If on, preserve overlay highlighting
                       (cf ediff or goo-font-lock) as well as basic faces.\n
Stefan Monnier's avatar
Stefan Monnier committed
453 454 455
  And the following are planned but not yet available:\n
  kill-context-leak  : Suppress hyperlinking between files highlighted by
                       different modes.\n
456
Note: like compiler optimizations, these optimize the _output_ of the code,
Stefan Monnier's avatar
Stefan Monnier committed
457
not the processing of the source itself, and are therefore likely to slow
458
htmlfontify down, at least a little.  Except for skip-refontification,
Stefan Monnier's avatar
Stefan Monnier committed
459 460 461 462 463 464 465 466 467
which can never slow you down, but may result in incomplete fontification."
  :type  '(set (const :tag "merge-adjacent-tags"  merge-adjacent-tags )
               (const :tag "zap-comment-links"    zap-comment-links   )
               (const :tag "zap-string-links"     zap-string-links    )
               (const :tag "skip-refontification" skip-refontification)
               (const :tag "kill-context-leak"    kill-context-leak   )
               (const :tag "div-wrapper"          div-wrapper         )
               (const :tag "keep-overlays"        keep-overlays       ))
  :group 'htmlfontify
468
  :tag   "optimizations")
Stefan Monnier's avatar
Stefan Monnier committed
469

470
(defvar hfy-tags-cache nil
Stefan Monnier's avatar
Stefan Monnier committed
471
  "Alist of the form:\n
472 473
\((\"/src/dir/0\" . tag-hash0) (\"/src/dir/1\" tag-hash1) ...)\n
Each tag hash entry then contains entries of the form:\n
Stefan Monnier's avatar
Stefan Monnier committed
474
\"tag_string\" => ((\"file/name.ext\" line char) ... )\n
475 476
ie an alist mapping (relative) file paths to line and character offsets.\n
See also `hfy-load-tags-cache'.")
Stefan Monnier's avatar
Stefan Monnier committed
477

478 479 480 481
(defvar hfy-tags-sortl nil
  "Alist of the form ((\"/src/dir\" . (tag0 tag1 tag2)) ... )\n
where the tags are stored in descending order of length.\n
See also `hfy-load-tags-cache'.")
Stefan Monnier's avatar
Stefan Monnier committed
482

483 484 485
(defvar hfy-tags-rmap nil
  "Alist of the form ((\"/src/dir\" . tag-rmap-hash))\n
where tag-rmap-hash has entries of the form:
Stefan Monnier's avatar
Stefan Monnier committed
486 487 488 489 490 491
\"tag_string\" => ( \"file/name.ext\" line char )
Unlike `hfy-tags-cache' these are the locations of occurrences of
tagged items, not the locations of their definitions.")

(defvar hfy-style-assoc 'please-ignore-this-line
  "An assoc representing/describing an Emacs face.
492 493
Properties may be repeated, in which case later properties should be
treated as if they were inherited from a 'parent' font.
Stefan Monnier's avatar
Stefan Monnier committed
494 495
\(For some properties, only the first encountered value is of any importance,
for others the values might be cumulative, and for others they might be
496
cumulative in a complex way.)\n
Stefan Monnier's avatar
Stefan Monnier committed
497
Some examples:\n
498 499 500 501 502 503 504 505 506 507 508 509 510 511
\(hfy-face-to-style 'default) =>
  ((\"background\"      . \"rgb(0, 0, 0)\")
   (\"color\"           . \"rgb(255, 255, 255)\")
   (\"font-style\"      . \"normal\")
   (\"font-weight\"     . \"500\")
   (\"font-stretch\"    . \"normal\")
   (\"font-family\"     . \"misc-fixed\")
   (\"font-size\"       . \"13pt\")
   (\"text-decoration\" . \"none\"))\n
\(hfy-face-to-style 'Info-title-3-face) =>
  ((\"font-weight\"     . \"700\")
   (\"font-family\"     . \"helv\")
   (\"font-size\"       . \"120%\")
   (\"text-decoration\" . \"none\"))\n")
Stefan Monnier's avatar
Stefan Monnier committed
512 513

(defvar hfy-sheet-assoc 'please-ignore-this-line
514 515 516
  "An assoc with elements of the form (face-name style-name . style-string):\n
'((default               \"default\" . \"{background: black; color: white}\")
  (font-lock-string-face \"string\"  . \"{color: rgb(64,224,208)}\"))" )
Stefan Monnier's avatar
Stefan Monnier committed
517 518

(defvar hfy-facemap-assoc 'please-ignore-this-line
519
  "An assoc of (point . FACE-SYMBOL) or (point . DEFFACE-LIST)
Stefan Monnier's avatar
Stefan Monnier committed
520
and (point . 'end) elements, in descending order of point value
521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539
\(ie from the file's end to its beginning).\n
The map is in reverse order because inserting a <style> tag (or any other
string) at `point' invalidates the map for all entries with a greater value of
point.  By traversing the map from greatest to least point, we still invalidate
the map as we go, but only those points we have already dealt with (and
therefore no longer care about) will be invalid at any time.\n
'((64820 . end)
  (64744 . font-lock-comment-face)
  (64736 . end)
  (64722 . font-lock-string-face)
  (64630 . end)
  (64623 . font-lock-string-face)
  (64449 . end)
  (64446 . font-lock-keyword-face)
  (64406 . end)
  (64395 . font-lock-constant-face)
  (64393 . end)
  (64386 . font-lock-keyword-face)
  (64379 . end)
Stefan Monnier's avatar
Stefan Monnier committed
540
  ;; big similar section elided.  You get the idea.
541 542 543 544 545 546 547
  (4285 . font-lock-constant-face)
  (4285 . end)
  (4221 . font-lock-comment-face)
  (4221 . end)
  (4197 . font-lock-constant-face)
  (4197 . end)
  (1 . font-lock-comment-face))")
Stefan Monnier's avatar
Stefan Monnier committed
548 549 550 551 552 553 554 555 556 557 558 559 560

(defvar hfy-tmpfont-stack nil
  "An alist of derived fonts resulting from overlays.")

(defconst hfy-hex-regex "[0-9A-Fa-f]")

(defconst hfy-triplet-regex
  (concat
   "\\(" hfy-hex-regex hfy-hex-regex "\\)"
   "\\(" hfy-hex-regex hfy-hex-regex "\\)"
   "\\(" hfy-hex-regex hfy-hex-regex "\\)"))

(defun hfy-interq (set-a set-b)
561
  "Return the intersection (using `eq') of two lists SET-A and SET-B."
Stefan Monnier's avatar
Stefan Monnier committed
562 563 564 565
  (let ((sa set-a) (interq nil) (elt nil))
    (while sa
      (setq elt (car sa)
            sa  (cdr sa))
566 567
      (if (memq elt set-b) (setq interq (cons elt interq))))
    interq))
Stefan Monnier's avatar
Stefan Monnier committed
568 569

(defun hfy-colour-vals (colour)
570 571
  "Where COLOUR is a color name or #XXXXXX style triplet, return a
list of three (16 bit) rgb values for said color.\n
Stefan Monnier's avatar
Stefan Monnier committed
572 573 574
If a window system is unavailable, calls `hfy-fallback-colour-values'."
  (if (string-match hfy-triplet-regex colour)
      (mapcar
575 576
       (lambda (x) (* (string-to-number (match-string x colour) 16) 257))
       '(1 2 3))
Stefan Monnier's avatar
Stefan Monnier committed
577 578 579 580 581 582
    ;;(message ">> %s" colour)
    (if window-system
        (if (fboundp 'color-values)
            (color-values colour)
          ;;(message "[%S]" window-system)
          (x-color-values colour))
Paul Eggert's avatar
Paul Eggert committed
583
      ;; blarg - tty colors are no good - go fetch some X colors:
Stefan Monnier's avatar
Stefan Monnier committed
584 585 586 587 588
      (hfy-fallback-colour-values colour))))

(defvar hfy-cperl-mode-kludged-p nil)

(defun hfy-kludge-cperl-mode ()
Paul Eggert's avatar
Paul Eggert committed
589
  "CPerl mode does its damnedest not to do some of its fontification when not
Stefan Monnier's avatar
Stefan Monnier committed
590 591 592 593 594 595 596 597
in a windowing system - try to trick it..."
  (if (not hfy-cperl-mode-kludged-p)
      (progn (if (not window-system)
                 (let ((window-system 'htmlfontify))
                   (eval-and-compile (require 'cperl-mode))
                   (setq cperl-syntaxify-by-font-lock t)))
             (setq hfy-cperl-mode-kludged-p t))) )

Juanma Barranquero's avatar
Juanma Barranquero committed
598 599
(defun hfy-opt (symbol)
  "Is option SYMBOL set."
600
  (memq symbol hfy-optimisations))
Stefan Monnier's avatar
Stefan Monnier committed
601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633

(defun hfy-default-header (file style)
  "Default value for `hfy-page-header'.
FILE is the name of the file.
STYLE is the inline CSS stylesheet (or tag referring to an external sheet)."
;;   (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
;; <html>\n <head>\n  <title>%s</title>\n %s\n </head>\n  <body>\n" file style))
  (format "<?xml version=\"1.0\" encoding=\"utf-8\"?>
<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\"
\"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">
<html xmlns=\"http://www.w3.org/1999/xhtml\">
  <head>
    <title>%s</title>
%s
    <script type=\"text/javascript\"><!--
  // this function is needed to work around
  // a bug in IE related to element attributes
  function hasClass(obj)
  {
      var result = false;
      if (obj.getAttributeNode(\"class\") != null)
      {
          result = obj.getAttributeNode(\"class\").value;
      }
      return result;
  }

  function stripe(id)
  {
      // the flag we'll use to keep track of
      // whether the current row is odd or even
      var even = false;

634
      // if arguments are provided to specify the colors
Stefan Monnier's avatar
Stefan Monnier committed
635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686
      // of the even & odd rows, then use the them;
      // otherwise use the following defaults:
      var evenColor = arguments[1] ? arguments[1] : \"#fff\";
      var oddColor  = arguments[2] ? arguments[2] : \"#ddd\";

      // obtain a reference to the desired table
      // if no such table exists, abort
      var table = document.getElementById(id);
      if (! table) { return; }

      // by definition, tables can have more than one tbody
      // element, so we'll have to get the list of child
      // &lt;tbody&gt;s
      var tbodies = table.getElementsByTagName(\"tbody\");

      // and iterate through them...
      for (var h = 0; h < tbodies.length; h++)
      {
          // find all the &lt;tr&gt; elements...
          var trs = tbodies[h].getElementsByTagName(\"tr\");

          // ... and iterate through them
          for (var i = 0; i < trs.length; i++)
          {
              // avoid rows that have a class attribute
              // or backgroundColor style
              if (! hasClass(trs[i]) &&
                  ! trs[i].style.backgroundColor)
              {
                  // get all the cells in this row...
                  var tds = trs[i].getElementsByTagName(\"td\");

                  // and iterate through them...
                  for (var j = 0; j < tds.length; j++)
                  {
                      var mytd = tds[j];

                      // avoid cells that have a class attribute
                      // or backgroundColor style
                      if (! hasClass(mytd) &&
                          ! mytd.style.backgroundColor)
                      {
                          mytd.style.backgroundColor =
                            even ? evenColor : oddColor;
                      }
                  }
              }
              // flip from odd to even, or vice-versa
              even =  ! even;
          }
      }
  }
Stefan Monnier's avatar
Stefan Monnier committed
687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708

  function toggle_invis( name )
  {
      var filter =
        { acceptNode:
          function( node )
          { var classname = node.id;
            if( classname )
            { var classbase = classname.substr( 0, name.length );
              if( classbase == name ) { return NodeFilter.FILTER_ACCEPT; } }
            return NodeFilter.FILTER_SKIP; } };
      var walker = document.createTreeWalker( document.body           ,
                                              NodeFilter.SHOW_ELEMENT ,
                                              filter                  ,
                                              false                   );
      while( walker.nextNode() )
      {
          var e = walker.currentNode;
          if( e.style.display == \"none\" ) { e.style.display = \"inline\"; }
          else                            { e.style.display = \"none\";   }
      }
  }
Stefan Monnier's avatar
Stefan Monnier committed
709 710 711 712 713
--> </script>
  </head>
  <body onload=\"stripe('index'); return true;\">\n"
          file style))

714
(defun hfy-default-footer (_file)
Stefan Monnier's avatar
Stefan Monnier committed
715 716 717 718 719
  "Default value for `hfy-page-footer'.
FILE is the name of the file being rendered, in case it is needed."
  "\n </body>\n</html>\n")

(defun hfy-link-style-string (style-string)
720
  "Replace the end of a CSS style declaration STYLE-STRING with the contents
Stefan Monnier's avatar
Stefan Monnier committed
721 722 723 724 725 726 727 728 729 730
of the variable `hfy-src-doc-link-style', removing text matching the regex
`hfy-src-doc-link-unstyle' first, if necessary."
  ;;(message "hfy-colour-vals");;DBUG
  (if (string-match hfy-src-doc-link-unstyle style-string)
      (setq style-string (replace-match "" 'fixed-case 'literal style-string)))
  (if (and (not (string-match hfy-src-doc-link-style style-string))
           (string-match "} *$" style-string))
      (concat (replace-match hfy-src-doc-link-style
                             'fixed-case
                             'literal
731 732
                             style-string) " }")
    style-string))
Stefan Monnier's avatar
Stefan Monnier committed
733 734 735 736

;; utility functions - cast emacs style specification values into their
;; css2 equivalents:
(defun hfy-triplet (colour)
737
  "Takes a COLOUR name (string) and return a CSS rgb(R, G, B) triplet string.
Stefan Monnier's avatar
Stefan Monnier committed
738
Uses the definition of \"white\" to map the numbers to the 0-255 range, so
739 740 741
if you've redefined white, (esp. if you've redefined it to have a triplet
member lower than that of the color you are processing) strange things
may happen."
Stefan Monnier's avatar
Stefan Monnier committed
742 743 744 745 746 747 748 749 750
  ;;(message "hfy-colour-vals");;DBUG
  (let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals "white")))
        (rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals  colour))))
    (if rgb16
        ;;(apply 'format "rgb(%d, %d, %d)"
        ;; Use #rrggbb instead, it is smaller
        (apply 'format "#%02x%02x%02x"
               (mapcar (lambda (X)
                         (* (/ (nth X rgb16)
751 752
                               (nth X white)) 255))
                       '(0 1 2))))))
Stefan Monnier's avatar
Stefan Monnier committed
753 754 755 756 757 758 759 760 761 762 763

(defun hfy-family (family) (list (cons "font-family"  family)))
(defun hfy-bgcol  (colour) (list (cons "background"   (hfy-triplet colour))))
(defun hfy-colour (colour) (list (cons "color"        (hfy-triplet colour))))
(defun hfy-width  (width)  (list (cons "font-stretch" (symbol-name  width))))

(defcustom hfy-font-zoom 1.05
  "Font scaling from Emacs to HTML."
  :type 'float
  :group 'htmlfontify)

764
(defun hfy-size (height)
Stefan Monnier's avatar
Stefan Monnier committed
765 766 767 768 769 770 771 772 773 774 775
  "Derive a CSS font-size specifier from an Emacs font :height attribute HEIGHT.
Does not cope with the case where height is a function to be applied to
the height of the underlying font."
  (list
   (cond
    ;;(t                 (cons "font-size" ": 1em"))
    ((floatp   height)
     (cons "font-size" (format "%d%%" (* (* hfy-font-zoom height) 100))))
    ((integerp height)
     (cons "font-size" (format "%dpt" (/ (* hfy-font-zoom height) 10 )))) )) )

776 777
(defun hfy-slant (slant)
  "Derive a font-style CSS specifier from the Emacs :slant attribute SLANT:
Stefan Monnier's avatar
Stefan Monnier committed
778 779
CSS does not define the reverse-* styles, so just maps those to the
regular specifiers."
780 781 782 783 784 785
  (list (cons "font-style"
              (or (cdr (assq slant '((italic          . "italic")
                                     (reverse-italic  . "italic" )
                                     (oblique         . "oblique")
                                     (reverse-oblique . "oblique"))))
                  "normal"))))
Stefan Monnier's avatar
Stefan Monnier committed
786 787

(defun hfy-weight (weight)
788
  "Derive a font-weight CSS specifier from an Emacs weight spec symbol WEIGHT."
789 790 791 792 793 794 795 796 797
  (list (cons "font-weight" (cdr (assq weight '((ultra-bold  . "900")
                                                (extra-bold  . "800")
                                                (bold        . "700")
                                                (semi-bold   . "600")
                                                (normal      . "500")
                                                (semi-light  . "400")
                                                (light       . "300")
                                                (extra-light . "200")
                                                (ultra-light . "100")))))))
798

Stefan Monnier's avatar
Stefan Monnier committed
799 800 801 802
(defun hfy-box-to-border-assoc (spec)
  (if spec
      (let ((tag (car  spec))
            (val (cadr spec)))
803 804 805 806 807
        (cons (case tag
                (:color (cons "colour" val))
                (:width (cons "width"  val))
                (:style (cons "style"  val)))
              (hfy-box-to-border-assoc (cddr spec))))))
Stefan Monnier's avatar
Stefan Monnier committed
808 809 810 811 812 813 814 815

(defun hfy-box-to-style (spec)
  (let* ((css (hfy-box-to-border-assoc  spec))
         (col (cdr      (assoc "colour" css)))
         (s   (cdr      (assoc "style"  css))))
    (list
     (if col (cons "border-color" (cdr (assoc "colour" css))))
     (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1)))
816 817 818 819
     (cons "border-style" (case s
                            (released-button "outset")
                            (pressed-button  "inset" )
                            (t               "solid" ))))))
Stefan Monnier's avatar
Stefan Monnier committed
820 821 822 823 824 825 826 827 828

(defun hfy-box (box)
  "Derive CSS border-* attributes from the Emacs :box attribute BOX."
  (if box
      (cond
       ((integerp box) (list (cons "border-width" (format "%dpx"   box))))
       ((stringp  box) (list (cons "border" (format "solid %s 1px" box))))
       ((listp    box) (hfy-box-to-style box)                            ))) )

829
(defun hfy-decor (tag _val)
Stefan Monnier's avatar
Stefan Monnier committed
830 831 832 833
  "Derive CSS text-decoration specifiers from various Emacs font attributes.
TAG is an Emacs font attribute key (eg :underline).
VAL is ignored."
  (list
834
   ;; FIXME: Why not '("text-decoration" . "underline")?  --Stef
835 836 837 838
   (case tag
     (:underline      (cons "text-decoration" "underline"   ))
     (:overline       (cons "text-decoration" "overline"    ))
     (:strike-through (cons "text-decoration" "line-through")))))
Stefan Monnier's avatar
Stefan Monnier committed
839

840
(defun hfy-invisible (&optional _val)
Stefan Monnier's avatar
Stefan Monnier committed
841 842 843 844 845 846 847
  "This text should be invisible.
Do something in CSS to make that happen.
VAL is ignored here."
  '(("display" . "none")))

(defun hfy-combined-face-spec (face)
  "Return a `defface' style alist of possible specifications for FACE.
848
Entries resulting from customization (`custom-set-faces') will take
Stefan Monnier's avatar
Stefan Monnier committed
849
precedence."
850 851 852 853 854
  (append
   (if (and hfy-display-class hfy-default-face-def (eq face 'default))
       hfy-default-face-def)
   (get face 'saved-face)
   (get face 'face-defface-spec)))
Stefan Monnier's avatar
Stefan Monnier committed
855 856 857

(defun hfy-face-attr-for-class (face &optional class)
  "Return the face attributes for FACE.
858
If CLASS is set, it must be a `defface' alist key [see below],
Stefan Monnier's avatar
Stefan Monnier committed
859
in which case the first face specification returned by `hfy-combined-face-spec'
860
which *doesn't* clash with CLASS is returned.\n
Stefan Monnier's avatar
Stefan Monnier committed
861
\(A specification with a class of t is considered to match any class you
862 863
specify - this matches Emacs' behavior when deciding on which face attributes
to use, to the best of my understanding).\n
Stefan Monnier's avatar
Stefan Monnier committed
864 865
If CLASS is nil, then you just get get whatever `face-attr-construct' returns,
ie the current specification in effect for FACE.\n
866 867
*NOTE*: This function forces any face that is not 'default and which has
no :inherit property to inherit from 'default (this is because 'default
Stefan Monnier's avatar
Stefan Monnier committed
868
is magical in that Emacs' fonts behave as if they inherit implicitly from
869 870
'default, but no such behavior exists in HTML/CSS).\n
See also `hfy-display-class' for details of valid values for CLASS."
871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939
  (let ((face-spec
         (if class
             (let ((face-props (hfy-combined-face-spec face))
                   (face-specn nil)
                   (face-class nil)
                   (face-attrs nil)
                   (face-score  -1)
                   (face-match nil))
               (while face-props
                 (setq face-specn (car face-props)
                       face-class (car face-specn)
                       face-attrs (cdr face-specn)
                       face-props (cdr face-props))
                 ;; if the current element CEL of CLASS is t we match
                 ;; if the current face-class is t, we match
                 ;; if the cdr of CEL has a non-nil
                 ;;   intersection with the cdr of the first member of
                 ;;   the current face-class with the same car as CEL, we match
                 ;; if we actually clash, then we can't match
                 (let ((cbuf class)
                       (cel    nil)
                       (key    nil)
                       (val    nil)
                       (x      nil)
                       (next   nil)
                       (score    0))
                   (while (and cbuf (not next))
                     (setq cel  (car cbuf)
                           cbuf (cdr cbuf)
                           key  (car  cel)
                           val  (cdr  cel)
                           val  (if (listp val) val (list val)))
                     (cond
                      ((or (eq cel t)
                           (memq face-class '(t default))) ;Default match.
                       (setq score 0) (ignore "t match"))
                      ((not (cdr (assq key face-class))) ;Neither good nor bad.
                       nil (ignore "non match, non collision"))
                      ((setq x (hfy-interq val (cdr (assq key face-class))))
                       (setq score (+ score (length x)))
                       (ignore "intersection"))
                      (t ;; nope.
                       (setq next t score -10) (ignore "collision")) ))
                   (if (> score face-score)
                       (progn
                         (setq face-match face-attrs
                               face-score score     )
                         (ignore "%d << %S/%S" score face-class class))
                     (ignore "--- %d ---- (insufficient)" score)) ))
               ;; matched ? last attrs : nil
               (if face-match
                   (if (listp (car face-match)) (car face-match) face-match)
                 nil))
           ;; Unfortunately the default face returns a
           ;; :background. Fortunately we can remove it, but how do we do
           ;; that in a non-system specific way?
           (let ((spec (face-attr-construct face))
                 (new-spec nil))
             (if (not (memq :background spec))
                 spec
               (while spec
                 (let ((a (nth 0 spec))
                       (b (nth 1 spec)))
                   (unless (and (eq a :background)
                                (stringp b)
                                (string= b "SystemWindow"))
                     (setq new-spec (cons a (cons b new-spec)))))
                 (setq spec (cddr spec)))
               new-spec)))))
Stefan Monnier's avatar
Stefan Monnier committed
940 941
    (if (or (memq :inherit face-spec) (eq 'default face))
        face-spec
942
      (append face-spec (list :inherit 'default)))))
Stefan Monnier's avatar
Stefan Monnier committed
943 944 945 946 947 948 949 950 951 952 953 954 955 956

;; construct an assoc of (css-tag-name . css-tag-value) pairs
;; from a face or assoc of face attributes:

;; Some tests etc:
;;  (mumamo-message-with-face "testing face" 'highlight)
;;  (mumamo-message-with-face "testing face" '(:foreground "red" :background "yellow"))
;;  (hfy-face-to-style-i '(:inherit default foreground-color "red"))
;;  default face=(:stipple nil :background "SystemWindow" :foreground
;;    "SystemWindowText" :inverse-video nil :box nil :strike-through
;;    nil :overline nil :underline nil :slant normal :weight normal
;;    :height 98 :width normal :family "outline-courier new")
(defun hfy-face-to-style-i (fn)
  "The guts of `hfy-face-to-style': FN should be a `defface' font spec,
957 958 959
as returned by `face-attr-construct' or `hfy-face-attr-for-class'.
Note that this function does not get font-sizes right if they are based
on inherited modifiers (via the :inherit) attribute, and any other
Stefan Monnier's avatar
Stefan Monnier committed
960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987
modifiers that are cumulative if they appear multiple times need to be
merged by the user - `hfy-flatten-style' should do this."
  ;;(message "hfy-face-to-style-i");;DBUG

  ;; fn's value could be something like
  ;; (:inherit
  ;;  ((foreground-color . "blue"))
  ;;  (foreground-color . "blue")
  ;;  nil)

  (when fn
    (let ((key  (car  fn))
          (val  (cadr fn))
          (next (cddr fn))
          (that       nil)
          (this       nil)
          (parent     nil))
      (if (eq key :inherit)
        (let ((vs (if (listp val) val (list val))))
          ;; (let ((x '(a b))) (setq x (append '(c d) x)))
          ;; (let ((x '(a b))) (setq x (append '(c d) x)))
          (dolist (v vs)
            (setq parent
                  (append
                   parent
                   (hfy-face-to-style-i
                    (hfy-face-attr-for-class v hfy-display-class)) ))))
        (setq this
988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002
              (if val (case key
                       (:family         (hfy-family    val))
                       (:width          (hfy-width     val))
                       (:weight         (hfy-weight    val))
                       (:slant          (hfy-slant     val))
                       (:foreground     (hfy-colour    val))
                       (:background     (hfy-bgcol     val))
                       (:box            (hfy-box       val))
                       (:height         (hfy-size      val))
                       (:underline      (hfy-decor key val))
                       (:overline       (hfy-decor key val))
                       (:strike-through (hfy-decor key val))
                       (:invisible      (hfy-invisible val))
                       (:bold           (hfy-weight  'bold))
                       (:italic         (hfy-slant 'italic))))))
Stefan Monnier's avatar
Stefan Monnier committed
1003 1004 1005 1006 1007
      (setq that (hfy-face-to-style-i next))
      ;;(lwarn t :warning "%S => %S" fn (nconc this that parent))
      (nconc this that parent))) )

(defun hfy-size-to-int (spec)
1008 1009
  "Convert SPEC, a CSS font-size specifier, to an Emacs :height attribute value.
Used while merging multiple font-size attributes."
Stefan Monnier's avatar
Stefan Monnier committed
1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025
  ;;(message "hfy-size-to-int");;DBUG
  (list
   (if (string-match "\\([0-9]+\\)\\(%\\|pt\\)" spec)
       (cond ((string= "%"  (match-string 2 spec))
              (/ (string-to-number (match-string 1 spec)) 100.0))
             ((string= "pt" (match-string 2 spec))
              (* (string-to-number (match-string 1 spec))    10)))
     (string-to-number spec))) )

;; size is different, in that in order to get it right at all,
;; we have to trawl the inheritance path, accumulating modifiers,
;; _until_ we get to an absolute (pt) specifier, then combine the lot
(defun hfy-flatten-style (style)
  "Take STYLE (see `hfy-face-to-style-i', `hfy-face-to-style') and merge
any multiple attributes appropriately.  Currently only font-size is merged
down to a single occurrence - others may need special handling, but I
1026
haven't encountered them yet.  Returns a `hfy-style-assoc'."
Stefan Monnier's avatar
Stefan Monnier committed
1027 1028 1029 1030 1031
  ;;(message "(hfy-flatten-style %S)" style) ;;DBUG
  (let ((n        0)
        (m (list 1))
        (x      nil)
        (r      nil))
1032 1033 1034 1035 1036 1037
    (dolist (css style)
      (if (string= (car css) "font-size")
          (progn
            (when (not x) (setq m (nconc m (hfy-size-to-int (cdr css)))))
            (when (string-match "pt" (cdr css)) (setq x t)))
        (setq r (nconc r (list css)))))
Stefan Monnier's avatar
Stefan Monnier committed
1038 1039 1040 1041
    ;;(message "r: %S" r)
    (setq  n (apply '* m))
    (nconc r (hfy-size (if x (round n) (* n 1.0)))) ))

1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053
(defun hfy-face-resolve-face (fn)
  (cond
   ((facep fn)
    (hfy-face-attr-for-class fn hfy-display-class))
   ((and (symbolp fn)
	 (facep (symbol-value fn)))
    ;; Obsolete faces like `font-lock-reference-face' are defined as
    ;; aliases for another face.
    (hfy-face-attr-for-class (symbol-value fn) hfy-display-class))
   (t nil)))


Stefan Monnier's avatar
Stefan Monnier committed
1054 1055
(defun hfy-face-to-style (fn)
  "Take FN, a font or `defface' style font specification,
1056
\(as returned by `face-attr-construct' or `hfy-face-attr-for-class')
Stefan Monnier's avatar
Stefan Monnier committed
1057
and return a `hfy-style-assoc'.\n
1058
See also `hfy-face-to-style-i', `hfy-flatten-style'."
Stefan Monnier's avatar
Stefan Monnier committed
1059
  ;;(message "hfy-face-to-style");;DBUG
1060 1061 1062
  (let* ((face-def (hfy-face-resolve-face fn))
         (final-style
          (hfy-flatten-style (hfy-face-to-style-i face-def))))
Stefan Monnier's avatar
Stefan Monnier committed
1063 1064 1065 1066 1067 1068 1069
    ;;(message "%S" final-style)
    (if (not (assoc "text-decoration" final-style))
        (progn (setq final-style
                     ;; Fix-me: there is no need for this since
                     ;; text-decoration is not inherited.
                     ;; but it's not wrong and if this ever changes it will
                     ;; be needed, so I think it's better to leave it in? -- v
Juanma Barranquero's avatar
Juanma Barranquero committed
1070
                     (nconc final-style '(("text-decoration" . "none"))))))
Stefan Monnier's avatar
Stefan Monnier committed
1071 1072 1073 1074 1075 1076 1077
    final-style))

;; strip redundant bits from a name. Technically, this could result in
;; a collision, but it is pretty unlikely - will fix later...
;; also handle ephemeral fonts created by overlays, which don't actually
;; have names:
(defun hfy-face-or-def-to-name (fn)
1078
  "Render a font symbol or `defface' font spec FN into a name (string)."
Stefan Monnier's avatar
Stefan Monnier committed
1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103
  ;;(message "generating name for %s" fn)
  (if (not (listp fn))
      (format "%s" fn)
    (let* ((key   (format       "%s"        fn))
           (entry (assoc key hfy-tmpfont-stack))
           (base  (cadr   (memq  :inherit  fn)))
           (tag   (cdr                   entry)))
      ;;(message "checking for key «%s» in font stack [%d]"
      ;;         key (if entry 1 0))
      (if entry nil ;; noop
        (setq tag               (format "%04d" (length hfy-tmpfont-stack))
              entry             (cons key tag)
              hfy-tmpfont-stack (cons entry hfy-tmpfont-stack)))
      ;;(message "  -> name: %s-%s" (or base 'default) tag)
      (format "%s-%s" (or base 'default) tag)) ))

(defun hfy-css-name (fn)
  "Strip the boring bits from a font-name FN and return a CSS style name."
  ;;(message "hfy-css-name");;DBUG
  (let ((face-name (hfy-face-or-def-to-name fn)))
    (if (or (string-match "font-lock-\\(.*\\)" face-name)
            (string-match "cperl-\\(.*\\)"     face-name)
            (string-match "^[Ii]nfo-\\(.*\\)"   face-name))
        (progn
          (setq face-name (match-string 1 face-name))
1104 1105 1106
          (if (string-match "\\(.*\\)-face\\'" face-name)
              (setq face-name (match-string 1 face-name)))
          face-name)
Stefan Monnier's avatar
Stefan Monnier committed
1107 1108 1109 1110 1111
      face-name)) )

;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs
;; from a face:
(defun hfy-face-to-css (fn)
1112
  "Take FN, a font or `defface' specification (cf `face-attr-construct')
Stefan Monnier's avatar
Stefan Monnier committed
1113
and return a CSS style specification.\n
1114
See also `hfy-face-to-style'."
Stefan Monnier's avatar
Stefan Monnier committed
1115
  ;;(message "hfy-face-to-css");;DBUG
1116 1117 1118
  (let* ((css-list (hfy-face-to-style fn))
         (seen     nil)
         (css-text
1119 1120 1121 1122 1123 1124
          (mapcar
           (lambda (E)
             (if (car E)
                 (unless (member (car E) seen)
                   (push (car E) seen)
                   (format " %s: %s; " (car E) (cdr E)))))
1125
           css-list)))
Stefan Monnier's avatar
Stefan Monnier committed
1126 1127
    (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) )

1128 1129 1130 1131 1132 1133 1134
(defalias 'hfy-prop-invisible-p
  (if (fboundp 'invisible-p) #'invisible-p
    (lambda (prop)
      "Is text property PROP an active invisibility property?"
      (or (and (eq buffer-invisibility-spec t) prop)
          (or (memq prop buffer-invisibility-spec)
              (assq prop buffer-invisibility-spec))))))
Stefan Monnier's avatar
Stefan Monnier committed
1135 1136 1137

(defun hfy-find-invisible-ranges ()
  "Return a list of (start-point . end-point) cons cells of invisible regions."
1138 1139
  (save-excursion
    (let (invisible p i s) ;; return-value pos invisible end start
Stefan Monnier's avatar
Stefan Monnier committed
1140 1141 1142 1143 1144
      (setq p (goto-char (point-min)))
      (when (invisible-p p) (setq s p i t))
      (while (< p (point-max))
        (if i ;; currently invisible
            (when (not (invisible-p p)) ;; but became visible
1145 1146
              (setq i         nil
                    invisible (cons (cons s p) invisible)))
Stefan Monnier's avatar
Stefan Monnier committed
1147 1148 1149 1150 1151 1152
          ;; currently visible:
          (when (invisible-p p)  ;; but have become invisible
            (setq s p i t)))
        (setq p (next-char-property-change p)))
      ;; still invisible at buffer end?
      (when i
1153
        (setq invisible (cons (cons s (point-max)) invisible)))
1154
      invisible)))
Stefan Monnier's avatar
Stefan Monnier committed
1155 1156 1157 1158 1159 1160 1161

(defun hfy-invisible-name (point map)
  "Generate a CSS style name for an invisible section of the buffer.
POINT is the point inside the invisible region.
MAP is the invisibility map as returned by `hfy-find-invisible-ranges'."
  ;;(message "(hfy-invisible-name %S %S)" point map)
  (let (name)
1162 1163 1164 1165
    (dolist (range map)
      (when (and (>= point (car range))
                 (<  point (cdr range)))
        (setq name (format "invisible-%S-%S" (car range) (cdr range)))))
Stefan Monnier's avatar
Stefan Monnier committed
1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176
    name))

;; Fix-me: This function needs some cleanup by someone who understand
;; all the formats that face properties can have.
;;
;; overlay handling should be fine. haven't tested multiple stacked overlapping
;; overlays recently, but the common case of a text property face + an overlay
;; face produces the correct merged css style (or as close to it as css can get)
;; -- v
(defun hfy-face-at (p)
  "Find face in effect at point P.
1177 1178
If overlays are to be considered (see `hfy-optimisations') then this may
return a `defface' style list of face properties instead of a face symbol."
Stefan Monnier's avatar
Stefan Monnier committed
1179 1180 1181
  ;;(message "hfy-face-at");;DBUG
  ;; Fix-me: clean up, remove face-name etc
  ;; not sure why we'd want to remove face-name? -- v
1182 1183
  (let ((overlay-data nil)
        (base-face    nil)
1184
        (face-name   (get-text-property p 'face))
1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299
        ;; (face-name    (hfy-get-face-at p))
        (prop-seen    nil)
        (extra-props  nil)
        (text-props   (text-properties-at p)))
    ;;(message "face-name: %S" face-name)
    (when (and face-name (listp face-name) (facep (car face-name)))
      ;;(message "face-name is a list %S" face-name)
      ;;(setq text-props (cons 'face face-name))
      (dolist (f face-name)
        (setq extra-props (if (listp f)
                              ;; for things like (variable-pitch
                              ;; (:foreground "red"))
                              (cons f extra-props)
                            (cons :inherit (cons f extra-props)))))
      (setq base-face (car face-name)
            face-name nil))
    ;; text-properties-at => (face (:foreground "red" ...))
    ;;                 or => (face (compilation-info underline)) list of faces
    ;; overlay-properties
    ;;   format= (evaporate t face ((foreground-color . "red")))

    ;; SO:    if we have turned overlays off,
    ;;     or if there's no overlay data
    ;; just bail out and return whatever face data we've accumulated so far
    (if (or (not (hfy-opt                      'keep-overlays))
            (not (setq overlay-data  (hfy-overlay-props-at p))))
        (progn
          ;;(message "· %d: %s; %S; %s"
          ;;         p face-name extra-props text-props)
          (or face-name base-face)) ;; no overlays or extra properties
      ;; collect any face data and any overlay data for processing:
      (when text-props
        (push text-props overlay-data))
      (setq overlay-data (nreverse overlay-data))
      ;;(message "- %d: %s; %S; %s; %s"
      ;;         p face-name extra-props text-props overlay-data)
      ;; remember the basic face name so we don't keep repeating its specs:
      (when face-name (setq base-face face-name))
      (dolist (P overlay-data)
        (let ((iprops (cadr (memq 'invisible P)))) ;FIXME: plist-get?
          ;;(message "(hfy-prop-invisible-p %S)" iprops)
          (when (and iprops (hfy-prop-invisible-p iprops))
            (setq extra-props
                  (cons :invisible (cons t extra-props))) ))
        (let ((fprops (cadr (or (memq 'face P)
                                (memq 'font-lock-face P)))))
          ;;(message "overlay face: %s" fprops)
          (if (not (listp fprops))
              (let ((this-face (if (stringp fprops) (intern fprops) fprops)))
                (when (not (eq this-face base-face))
                  (setq extra-props
                        (cons :inherit
                              (cons this-face extra-props))) ))
            (while fprops
              (if (facep (car fprops))
                  (let ((face (car fprops)))
                    (when (stringp face) (setq face (intern fprops)))
                    (setq extra-props
                          (cons :inherit
                                (cons face
                                      extra-props)))
                    (setq fprops (cdr fprops)))
                (let (p v)
                  ;; Sigh.
                  (if (listp (car fprops))
                      (if (nlistp (cdr (car fprops)))
                          (progn
                            ;; ((prop . val))
                            (setq p (caar fprops))
                            (setq v (cdar fprops))
                            (setq fprops (cdr fprops)))
                        ;; ((prop val))
                        (setq p (caar fprops))
                        (setq v (cadar fprops))
                        (setq fprops (cdr fprops)))
                    (if (listp (cdr fprops))
                        (progn
                          ;; (:prop val :prop val ...)
                          (setq p (car fprops))
                          (setq v (cadr fprops))
                          (setq fprops (cddr fprops)))
                      (if (and (listp fprops)
                               (not (listp (cdr fprops))))
                          ;;(and (consp x) (cdr (last x)))
                          (progn
                            ;; (prop . val)
                            (setq p (car fprops))
                            (setq v (cdr fprops))
                            (setq fprops nil))
                        (error "Eh... another format! fprops=%s" fprops) )))
                  (setq p (case p
                            ;; These are all the properties handled
                            ;; in `hfy-face-to-style-i'.
                            ;;
                            ;; Are these translations right?
                            ;; yes, they are -- v
                            (family           :family    )
                            (width            :width     )
                            (height           :height    )
                            (weight           :weight    )
                            (slant            :slant     )
                            (underline        :underline )
                            (overline         :overline  )
                            (strike-through   :strike-through)
                            (box              :box       )
                            (foreground-color :foreground)
                            (background-color :background)
                            (bold             :bold      )
                            (italic           :italic    )
                            (t                 p)))
                  (if (memq p prop-seen) nil ;; noop
                    (setq prop-seen   (cons p prop-seen)
                          extra-props (cons p (cons v extra-props))))))))))
      ;;(message "+ %d: %s; %S" p face-name extra-props)
      (if extra-props
Stefan Monnier's avatar