aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2009-11-26 16:24:36 +0000
committerStefan Monnier2009-11-26 16:24:36 +0000
commit72fe6b25a283acd4c8f5a6c4e7393efa84649821 (patch)
treea1565e2c364c344feb5ecc855673e4b551ce4537
parent85e0a5363c644d8886b7b14a864491f3776fac03 (diff)
downloademacs-72fe6b25a283acd4c8f5a6c4e7393efa84649821.tar.gz
emacs-72fe6b25a283acd4c8f5a6c4e7393efa84649821.zip
Misc coding convention cleanups.
* htmlfontify.el (hfy-init-kludge-hook): Rename from hfy-init-kludge-hooks. (hfy-etags-cmd, hfy-flatten-style, hfy-invisible-name, hfy-face-at) (hfy-fontify-buffer, hfy-prepare-index-i, hfy-subtract-maps) (hfy-save-kill-buffers, htmlfontify-copy-and-link-dir): Use dolist and push. (hfy-slant, hfy-weight): Use tables rather than code. (hfy-box-to-border-assoc, hfy-box-to-style, hfy-decor) (hfy-face-to-style-i, hfy-fontify-buffer): Use `case'. (hfy-face-attr-for-class): Initialize `face-spec' directly. (hfy-face-to-css): Remove `nconc' with single arg. (hfy-p-to-face-lennart): Use `or'. (hfy-face-at): Hoist common code. Remove spurious quotes in `case'. (hfy-overlay-props-at, hfy-mark-tag-hrefs): Eta-reduce. (hfy-compile-stylesheet, hfy-merge-adjacent-spans) (hfy-compile-face-map, hfy-parse-tags-buffer): Use push. (hfy-force-fontification): Use run-hooks.
-rw-r--r--lisp/ChangeLog21
-rw-r--r--lisp/htmlfontify.el775
2 files changed, 407 insertions, 389 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 4e7266feda1..a1f83dc15a0 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,24 @@
12009-11-26 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 Misc coding convention cleanups.
4 * htmlfontify.el (hfy-init-kludge-hook): Rename from
5 hfy-init-kludge-hooks.
6 (hfy-etags-cmd, hfy-flatten-style, hfy-invisible-name, hfy-face-at)
7 (hfy-fontify-buffer, hfy-prepare-index-i, hfy-subtract-maps)
8 (hfy-save-kill-buffers, htmlfontify-copy-and-link-dir): Use dolist
9 and push.
10 (hfy-slant, hfy-weight): Use tables rather than code.
11 (hfy-box-to-border-assoc, hfy-box-to-style, hfy-decor)
12 (hfy-face-to-style-i, hfy-fontify-buffer): Use `case'.
13 (hfy-face-attr-for-class): Initialize `face-spec' directly.
14 (hfy-face-to-css): Remove `nconc' with single arg.
15 (hfy-p-to-face-lennart): Use `or'.
16 (hfy-face-at): Hoist common code. Remove spurious quotes in `case'.
17 (hfy-overlay-props-at, hfy-mark-tag-hrefs): Eta-reduce.
18 (hfy-compile-stylesheet, hfy-merge-adjacent-spans)
19 (hfy-compile-face-map, hfy-parse-tags-buffer): Use push.
20 (hfy-force-fontification): Use run-hooks.
21
12009-11-26 Vivek Dasmohapatra <vivek@etla.org> 222009-11-26 Vivek Dasmohapatra <vivek@etla.org>
2 23
3 Various minor fixes. 24 Various minor fixes.
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el
index a46ad334278..48bd7d921f9 100644
--- a/lisp/htmlfontify.el
+++ b/lisp/htmlfontify.el
@@ -183,17 +183,19 @@ See: `htmlfontify-manual'"
183 :prefix "hfy-") 183 :prefix "hfy-")
184 184
185(defcustom hfy-page-header 'hfy-default-header 185(defcustom hfy-page-header 'hfy-default-header
186 "*Function called with two arguments \(the filename relative to the top 186 "Function called with two arguments \(the filename relative to the top
187level source directory being etag\'d and fontified), and a string containing 187level source directory being etag\'d and fontified), and a string containing
188the <style>...</style> text to embed in the document- the string returned will 188the <style>...</style> text to embed in the document- the string returned will
189be used as the header for the htmlfontified version of the source file.\n 189be used as the header for the htmlfontified version of the source file.\n
190See also: `hfy-page-footer'" 190See also: `hfy-page-footer'"
191 :group 'htmlfontify 191 :group 'htmlfontify
192 ;; FIXME: Why place such a :tag everywhere? Isn't it imposing your
193 ;; own Custom preference on your users? --Stef
192 :tag "page-header" 194 :tag "page-header"
193 :type '(function)) 195 :type '(function))
194 196
195(defcustom hfy-split-index nil 197(defcustom hfy-split-index nil
196 "*Whether or not to split the index `hfy-index-file' alphabetically 198 "Whether or not to split the index `hfy-index-file' alphabetically
197on the first letter of each tag. Useful when the index would otherwise 199on the first letter of each tag. Useful when the index would otherwise
198be large and take a long time to render or be difficult to navigate." 200be large and take a long time to render or be difficult to navigate."
199 :group 'htmlfontify 201 :group 'htmlfontify
@@ -201,32 +203,32 @@ be large and take a long time to render or be difficult to navigate."
201 :type '(boolean)) 203 :type '(boolean))
202 204
203(defcustom hfy-page-footer 'hfy-default-footer 205(defcustom hfy-page-footer 'hfy-default-footer
204 "*As `hfy-page-header', but generates the output footer 206 "As `hfy-page-header', but generates the output footer
205\(and takes only 1 argument, the filename\)." 207\(and takes only 1 argument, the filename\)."
206 :group 'htmlfontify 208 :group 'htmlfontify
207 :tag "page-footer" 209 :tag "page-footer"
208 :type '(function)) 210 :type '(function))
209 211
210(defcustom hfy-extn ".html" 212(defcustom hfy-extn ".html"
211 "*File extension used for output files." 213 "File extension used for output files."
212 :group 'htmlfontify 214 :group 'htmlfontify
213 :tag "extension" 215 :tag "extension"
214 :type '(string)) 216 :type '(string))
215 217
216(defcustom hfy-src-doc-link-style "text-decoration: underline;" 218(defcustom hfy-src-doc-link-style "text-decoration: underline;"
217 "*String to add to the \'<style> a\' variant of an htmlfontify css class." 219 "String to add to the \'<style> a\' variant of an htmlfontify css class."
218 :group 'htmlfontify 220 :group 'htmlfontify
219 :tag "src-doc-link-style" 221 :tag "src-doc-link-style"
220 :type '(string)) 222 :type '(string))
221 223
222(defcustom hfy-src-doc-link-unstyle " text-decoration: none;" 224(defcustom hfy-src-doc-link-unstyle " text-decoration: none;"
223 "*Regex to remove from the <style> a variant of an htmlfontify css class." 225 "Regex to remove from the <style> a variant of an htmlfontify css class."
224 :group 'htmlfontify 226 :group 'htmlfontify
225 :tag "src-doc-link-unstyle" 227 :tag "src-doc-link-unstyle"
226 :type '(string)) 228 :type '(string))
227 229
228(defcustom hfy-link-extn nil 230(defcustom hfy-link-extn nil
229 "*File extension used for href links - Useful where the htmlfontify 231 "File extension used for href links - Useful where the htmlfontify
230output files are going to be processed again, with a resulting change 232output files are going to be processed again, with a resulting change
231in file extension. If nil, then any code using this should fall back 233in file extension. If nil, then any code using this should fall back
232to `hfy-extn'." 234to `hfy-extn'."
@@ -235,7 +237,7 @@ to `hfy-extn'."
235 :type '(choice string (const nil))) 237 :type '(choice string (const nil)))
236 238
237(defcustom hfy-link-style-fun 'hfy-link-style-string 239(defcustom hfy-link-style-fun 'hfy-link-style-string
238 "*Set this to a function, which will be called with one argument 240 "Set this to a function, which will be called with one argument
239\(a \"{ foo: bar; ...}\" css style-string\) - it should return a copy of 241\(a \"{ foo: bar; ...}\" css style-string\) - it should return a copy of
240its argument, altered so as to make any changes you want made for text which 242its argument, altered so as to make any changes you want made for text which
241is a hyperlink, in addition to being in the class to which that style would 243is a hyperlink, in addition to being in the class to which that style would
@@ -245,29 +247,31 @@ normally be applied."
245 :type '(function)) 247 :type '(function))
246 248
247(defcustom hfy-index-file "hfy-index" 249(defcustom hfy-index-file "hfy-index"
248 "*Name \(sans extension\) of the tag definition index file produced during 250 "Name \(sans extension\) of the tag definition index file produced during
249fontification-and-hyperlinking." 251fontification-and-hyperlinking."
250 :group 'htmlfontify 252 :group 'htmlfontify
251 :tag "index-file" 253 :tag "index-file"
252 :type '(string)) 254 :type '(string))
253 255
254(defcustom hfy-instance-file "hfy-instance" 256(defcustom hfy-instance-file "hfy-instance"
255 "*Name \(sans extension\) of the tag usage index file produced during 257 "Name \(sans extension\) of the tag usage index file produced during
256fontification-and-hyperlinking." 258fontification-and-hyperlinking."
257 :group 'htmlfontify 259 :group 'htmlfontify
258 :tag "instance-file" 260 :tag "instance-file"
259 :type '(string)) 261 :type '(string))
260 262
261(defcustom hfy-html-quote-regex "\\(<\\|\"\\|&\\|>\\)" 263(defcustom hfy-html-quote-regex "\\(<\\|\"\\|&\\|>\\)"
262 "*Regex to match \(with a single back-reference per match\) strings in HTML 264 "Regex to match \(with a single back-reference per match\) strings in HTML
263which should be quoted with `hfy-html-quote' \(and `hfy-html-quote-map'\) 265which should be quoted with `hfy-html-quote' \(and `hfy-html-quote-map'\)
264to make them safe." 266to make them safe."
265 :group 'htmlfontify 267 :group 'htmlfontify
266 :tag "html-quote-regex" 268 :tag "html-quote-regex"
267 :type '(regexp)) 269 :type '(regexp))
268 270
269(defcustom hfy-init-kludge-hooks '(hfy-kludge-cperl-mode) 271(define-obsolete-variable-alias 'hfy-init-kludge-hooks 'hfy-init-kludge-hook
270 "*List of functions to call when starting htmlfontify-buffer to do any 272 "23.2")
273(defcustom hfy-init-kludge-hook '(hfy-kludge-cperl-mode)
274 "List of functions to call when starting htmlfontify-buffer to do any
271kludging necessary to get highlighting modes to bahave as you want, even 275kludging necessary to get highlighting modes to bahave as you want, even
272when not running under a window system." 276when not running under a window system."
273 :group 'htmlfontify 277 :group 'htmlfontify
@@ -275,7 +279,7 @@ when not running under a window system."
275 :type '(hook)) 279 :type '(hook))
276 280
277(defcustom hfy-post-html-hooks nil 281(defcustom hfy-post-html-hooks nil
278 "*List of functions to call after creating and filling the html buffer. 282 "List of functions to call after creating and filling the html buffer.
279These functions will be called with the html buffer as the current buffer" 283These functions will be called with the html buffer as the current buffer"
280 :group 'htmlfontify 284 :group 'htmlfontify
281 :tag "post-html-hooks" 285 :tag "post-html-hooks"
@@ -283,7 +287,7 @@ These functions will be called with the html buffer as the current buffer"
283 :type '(hook)) 287 :type '(hook))
284 288
285(defcustom hfy-default-face-def nil 289(defcustom hfy-default-face-def nil
286 "*Fallback `defface' specification for the face \'default, used when 290 "Fallback `defface' specification for the face \'default, used when
287`hfy-display-class' has been set \(the normal htmlfontify way of extracting 291`hfy-display-class' has been set \(the normal htmlfontify way of extracting
288potentially non-current face information doesn\'t necessarily work for 292potentially non-current face information doesn\'t necessarily work for
289\'default\).\n 293\'default\).\n
@@ -298,7 +302,7 @@ Example: I customise this to:\n
298 "\x01" "\\([0-9]+\\)" 302 "\x01" "\\([0-9]+\\)"
299 "," "\\([0-9]+\\)$" 303 "," "\\([0-9]+\\)$"
300 "\\|" ".*\x7f[0-9]+,[0-9]+$") 304 "\\|" ".*\x7f[0-9]+,[0-9]+$")
301 "*Regex used to parse an etags entry: must have 3 subexps, corresponding, 305 "Regex used to parse an etags entry: must have 3 subexps, corresponding,
302in order, to:\n 306in order, to:\n
303 1 - The tag 307 1 - The tag
304 2 - The line 308 2 - The line
@@ -311,7 +315,7 @@ in order, to:\n
311 ("<" "&lt;" ) 315 ("<" "&lt;" )
312 ("&" "&amp;" ) 316 ("&" "&amp;" )
313 (">" "&gt;" )) 317 (">" "&gt;" ))
314 "*Alist of char -> entity mappings used to make the text html-safe." 318 "Alist of char -> entity mappings used to make the text html-safe."
315 :group 'htmlfontify 319 :group 'htmlfontify
316 :tag "html-quote-map" 320 :tag "html-quote-map"
317 :type '(alist :key-type (string))) 321 :type '(alist :key-type (string)))
@@ -353,14 +357,14 @@ done;")
353 357
354 (defcustom hfy-etags-cmd-alist 358 (defcustom hfy-etags-cmd-alist
355 hfy-etags-cmd-alist-default 359 hfy-etags-cmd-alist-default
356 "*Alist of possible shell commands that will generate etags output that 360 "Alist of possible shell commands that will generate etags output that
357`htmlfontify' can use. \'%s\' will be replaced by `hfy-etags-bin'." 361`htmlfontify' can use. \'%s\' will be replaced by `hfy-etags-bin'."
358 :group 'htmlfontify 362 :group 'htmlfontify
359 :tag "etags-cmd-alist" 363 :tag "etags-cmd-alist"
360 :type '(alist :key-type (string) :value-type (string)) )) 364 :type '(alist :key-type (string) :value-type (string)) ))
361 365
362(defcustom hfy-etags-bin "etags" 366(defcustom hfy-etags-bin "etags"
363 "*Location of etags binary (we begin by assuming it\'s in your path).\n 367 "Location of etags binary (we begin by assuming it\'s in your path).\n
364Note that if etags is not in your path, you will need to alter the shell 368Note that if etags is not in your path, you will need to alter the shell
365commands in `hfy-etags-cmd-alist'." 369commands in `hfy-etags-cmd-alist'."
366 :group 'htmlfontify 370 :group 'htmlfontify
@@ -368,7 +372,7 @@ commands in `hfy-etags-cmd-alist'."
368 :type '(file)) 372 :type '(file))
369 373
370(defcustom hfy-shell-file-name "/bin/sh" 374(defcustom hfy-shell-file-name "/bin/sh"
371 "*Shell (bourne or compatible) to invoke for complex shell operations." 375 "Shell (bourne or compatible) to invoke for complex shell operations."
372 :group 'htmlfontify 376 :group 'htmlfontify
373 :tag "shell-file-name" 377 :tag "shell-file-name"
374 :type '(file)) 378 :type '(file))
@@ -381,7 +385,7 @@ commands in `hfy-etags-cmd-alist'."
381 385
382(defcustom hfy-etags-cmd 386(defcustom hfy-etags-cmd
383 (eval-and-compile (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist))) 387 (eval-and-compile (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist)))
384 "*The etags equivalent command to run in a source directory to generate a tags 388 "The etags equivalent command to run in a source directory to generate a tags
385file for the whole source tree from there on down. The command should emit 389file for the whole source tree from there on down. The command should emit
386the etags output on stdout.\n 390the etags output on stdout.\n
387Two canned commands are provided - they drive Emacs\' etags and 391Two canned commands are provided - they drive Emacs\' etags and
@@ -390,15 +394,12 @@ exuberant-ctags\' etags respectively."
390 :tag "etags-command" 394 :tag "etags-command"
391 :type (eval-and-compile 395 :type (eval-and-compile
392 (let ((clist (list '(string)))) 396 (let ((clist (list '(string))))
393 (mapc 397 (dolist (C hfy-etags-cmd-alist)
394 (lambda (C) 398 (push (list 'const :tag (car C) (cdr C)) clist))
395 (setq clist
396 (cons (list 'const :tag (car C) (cdr C)) clist)))
397 hfy-etags-cmd-alist)
398 (cons 'choice clist)) )) 399 (cons 'choice clist)) ))
399 400
400(defcustom hfy-istext-command "file %s | sed -e 's@^[^:]*:[ \t]*@@'" 401(defcustom hfy-istext-command "file %s | sed -e 's@^[^:]*:[ \t]*@@'"
401 "*Command to run with the name of a file, to see whether it is a text file 402 "Command to run with the name of a file, to see whether it is a text file
402or not. The command should emit a string containing the word \'text\' if 403or not. The command should emit a string containing the word \'text\' if
403the file is a text file, and a string not containing \'text\' otherwise." 404the file is a text file, and a string not containing \'text\' otherwise."
404 :group 'htmlfontify 405 :group 'htmlfontify
@@ -407,13 +408,13 @@ the file is a text file, and a string not containing \'text\' otherwise."
407 408
408(defcustom hfy-find-cmd 409(defcustom hfy-find-cmd
409 "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*" 410 "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*"
410 "*Find command used to harvest a list of files to attempt to fontify." 411 "Find command used to harvest a list of files to attempt to fontify."
411 :group 'htmlfontify 412 :group 'htmlfontify
412 :tag "find-command" 413 :tag "find-command"
413 :type '(string)) 414 :type '(string))
414 415
415(defcustom hfy-display-class nil 416(defcustom hfy-display-class nil
416 "*Display class to use to determine which display class to use when 417 "Display class to use to determine which display class to use when
417calculating a face\'s attributes. This is useful when, for example, you 418calculating a face\'s attributes. This is useful when, for example, you
418are running Emacs on a tty or in batch mode, and want htmlfontify to have 419are running Emacs on a tty or in batch mode, and want htmlfontify to have
419access to the face spec you would use if you were connected to an X display.\n 420access to the face spec you would use if you were connected to an X display.\n
@@ -451,7 +452,7 @@ and so on."
451 (const :tag "Bright" light ))) )) 452 (const :tag "Bright" light ))) ))
452 453
453(defcustom hfy-optimisations (list 'keep-overlays) 454(defcustom hfy-optimisations (list 'keep-overlays)
454 "*Optimisations to turn on: So far, the following have been implemented:\n 455 "Optimisations to turn on: So far, the following have been implemented:\n
455 merge-adjacent-tags: If two (or more) span tags are adjacent, identical and 456 merge-adjacent-tags: If two (or more) span tags are adjacent, identical and
456 separated by nothing more than whitespace, they will 457 separated by nothing more than whitespace, they will
457 be merged into one span. 458 be merged into one span.
@@ -583,8 +584,8 @@ list of 3 (16 bit) rgb values for said colour.\n
583If a window system is unavailable, calls `hfy-fallback-colour-values'." 584If a window system is unavailable, calls `hfy-fallback-colour-values'."
584 (if (string-match hfy-triplet-regex colour) 585 (if (string-match hfy-triplet-regex colour)
585 (mapcar 586 (mapcar
586 (lambda (x) 587 (lambda (x) (* (string-to-number (match-string x colour) 16) 257))
587 (* (string-to-number (match-string x colour) 16) 257)) '(1 2 3)) 588 '(1 2 3))
588 ;;(message ">> %s" colour) 589 ;;(message ">> %s" colour)
589 (if window-system 590 (if window-system
590 (if (fboundp 'color-values) 591 (if (fboundp 'color-values)
@@ -756,7 +757,8 @@ may happen\)."
756 (apply 'format "#%02x%02x%02x" 757 (apply 'format "#%02x%02x%02x"
757 (mapcar (lambda (X) 758 (mapcar (lambda (X)
758 (* (/ (nth X rgb16) 759 (* (/ (nth X rgb16)
759 (nth X white)) 255)) '(0 1 2))))) ) 760 (nth X white)) 255))
761 '(0 1 2))))))
760 762
761(defun hfy-family (family) (list (cons "font-family" family))) 763(defun hfy-family (family) (list (cons "font-family" family)))
762(defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour)))) 764(defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour))))
@@ -784,32 +786,34 @@ the height of the underlying font."
784 "Derive a font-style css specifier from the Emacs :slant attribute SLANT: 786 "Derive a font-style css specifier from the Emacs :slant attribute SLANT:
785CSS does not define the reverse-* styles, so just maps those to the 787CSS does not define the reverse-* styles, so just maps those to the
786regular specifiers." 788regular specifiers."
787 (list (cons "font-style" (cond ((eq 'italic slant) "italic" ) 789 (list (cons "font-style"
788 ((eq 'reverse-italic slant) "italic" ) 790 (or (cdr (assq slant '((italic . "italic")
789 ((eq 'oblique slant) "oblique") 791 (reverse-italic . "italic" )
790 ((eq 'reverse-oblique slant) "oblique") 792 (oblique . "oblique")
791 (t "normal" )))) ) 793 (reverse-oblique . "oblique"))))
794 "normal"))))
792 795
793(defun hfy-weight (weight) 796(defun hfy-weight (weight)
794 "Derive a font-weight css specifier from an Emacs weight spec symbol WEIGHT." 797 "Derive a font-weight css specifier from an Emacs weight spec symbol WEIGHT."
795 (list (cons "font-weight" (cond ((eq 'ultra-bold weight) "900") 798 (list (cons "font-weight" (cdr (assq weight '((ultra-bold . "900")
796 ((eq 'extra-bold weight) "800") 799 (extra-bold . "800")
797 ((eq 'bold weight) "700") 800 (bold . "700")
798 ((eq 'semi-bold weight) "600") 801 (semi-bold . "600")
799 ((eq 'normal weight) "500") 802 (normal . "500")
800 ((eq 'semi-light weight) "400") 803 (semi-light . "400")
801 ((eq 'light weight) "300") 804 (light . "300")
802 ((eq 'extra-light weight) "200") 805 (extra-light . "200")
803 ((eq 'ultra-light weight) "100")))) ) 806 (ultra-light . "100")))))))
804 807
805(defun hfy-box-to-border-assoc (spec) 808(defun hfy-box-to-border-assoc (spec)
806 (if spec 809 (if spec
807 (let ((tag (car spec)) 810 (let ((tag (car spec))
808 (val (cadr spec))) 811 (val (cadr spec)))
809 (cons (cond ((eq tag :color) (cons "colour" val)) 812 (cons (case tag
810 ((eq tag :width) (cons "width" val)) 813 (:color (cons "colour" val))
811 ((eq tag :style) (cons "style" val))) 814 (:width (cons "width" val))
812 (hfy-box-to-border-assoc (cddr spec))))) ) 815 (:style (cons "style" val)))
816 (hfy-box-to-border-assoc (cddr spec))))))
813 817
814(defun hfy-box-to-style (spec) 818(defun hfy-box-to-style (spec)
815 (let* ((css (hfy-box-to-border-assoc spec)) 819 (let* ((css (hfy-box-to-border-assoc spec))
@@ -818,9 +822,10 @@ regular specifiers."
818 (list 822 (list
819 (if col (cons "border-color" (cdr (assoc "colour" css)))) 823 (if col (cons "border-color" (cdr (assoc "colour" css))))
820 (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1))) 824 (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1)))
821 (cons "border-style" (cond ((eq s 'released-button) "outset") 825 (cons "border-style" (case s
822 ((eq s 'pressed-button ) "inset" ) 826 (released-button "outset")
823 (t "solid" ))))) ) 827 (pressed-button "inset" )
828 (t "solid" ))))))
824 829
825(defun hfy-box (box) 830(defun hfy-box (box)
826 "Derive CSS border-* attributes from the Emacs :box attribute BOX." 831 "Derive CSS border-* attributes from the Emacs :box attribute BOX."
@@ -836,9 +841,10 @@ TAG is an Emacs font attribute key (eg :underline).
836VAL is ignored." 841VAL is ignored."
837 (list 842 (list
838 ;; FIXME: Why not '("text-decoration" . "underline")? --Stef 843 ;; FIXME: Why not '("text-decoration" . "underline")? --Stef
839 (cond ((eq tag :underline ) (cons "text-decoration" "underline" )) 844 (case tag
840 ((eq tag :overline ) (cons "text-decoration" "overline" )) 845 (:underline (cons "text-decoration" "underline" ))
841 ((eq tag :strike-through) (cons "text-decoration" "line-through"))))) 846 (:overline (cons "text-decoration" "overline" ))
847 (:strike-through (cons "text-decoration" "line-through")))))
842 848
843(defun hfy-invisible (&optional val) 849(defun hfy-invisible (&optional val)
844 "This text should be invisible. 850 "This text should be invisible.
@@ -871,75 +877,75 @@ no :inherit property to inherit from \'default \( this is because \'default
871is magical in that Emacs' fonts behave as if they inherit implicitly from 877is magical in that Emacs' fonts behave as if they inherit implicitly from
872\'default, but no such behaviour exists in HTML/CSS \).\n 878\'default, but no such behaviour exists in HTML/CSS \).\n
873See `hfy-display-class' for details of valid values for CLASS." 879See `hfy-display-class' for details of valid values for CLASS."
874 (let ((face-spec nil)) 880 (let ((face-spec
875 (setq 881 (if class
876 face-spec 882 (let ((face-props (hfy-combined-face-spec face))
877 (if class 883 (face-specn nil)
878 (let ((face-props (hfy-combined-face-spec face)) 884 (face-class nil)
879 (face-specn nil) 885 (face-attrs nil)
880 (face-class nil) 886 (face-score -1)
881 (face-attrs nil) 887 (face-match nil))
882 (face-score -1) 888 (while face-props
883 (face-match nil)) 889 (setq face-specn (car face-props)
884 (while face-props 890 face-class (car face-specn)
885 (setq face-specn (car face-props) 891 face-attrs (cdr face-specn)
886 face-class (car face-specn) 892 face-props (cdr face-props))
887 face-attrs (cdr face-specn) 893 ;; if the current element CEL of CLASS is t we match
888 face-props (cdr face-props)) 894 ;; if the current face-class is t, we match
889 ;; if the current element CEL of CLASS is t we match 895 ;; if the cdr of CEL has a non-nil
890 ;; if the current face-class is t, we match 896 ;; intersection with the cdr of the first member of
891 ;; if the cdr of CEL has a non-nil 897 ;; the current face-class with the same car as CEL, we match
892 ;; intersection with the cdr of the first member of 898 ;; if we actually clash, then we can't match
893 ;; the current face-class with the same car as CEL, we match 899 (let ((cbuf class)
894 ;; if we actually clash, then we can't match 900 (cel nil)
895 (let ((cbuf class) 901 (key nil)
896 (cel nil) 902 (val nil)
897 (key nil) 903 (x nil)
898 (val nil) 904 (next nil)
899 (x nil) 905 (score 0))
900 (next nil) 906 (while (and cbuf (not next))
901 (score 0)) 907 (setq cel (car cbuf)
902 (while (and cbuf (not next)) 908 cbuf (cdr cbuf)
903 (setq cel (car cbuf) 909 key (car cel)
904 cbuf (cdr cbuf) 910 val (cdr cel)
905 key (car cel) 911 val (if (listp val) val (list val)))
906 val (cdr cel) 912 (cond
907 val (if (listp val) val (list val))) 913 ((or (eq cel t)
908 (cond 914 (memq face-class '(t default))) ;Default match.
909 ((or (eq cel t) (memq face-class '(t default)));;default match 915 (setq score 0) (ignore "t match"))
910 (setq score 0) (ignore "t match")) 916 ((not (cdr (assq key face-class))) ;Neither good nor bad.
911 ((not (cdr (assq key face-class))) ;; neither good nor bad 917 nil (ignore "non match, non collision"))
912 nil (ignore "non match, non collision")) 918 ((setq x (hfy-interq val (cdr (assq key face-class))))
913 ((setq x (hfy-interq val (cdr (assq key face-class)))) 919 (setq score (+ score (length x)))
914 (setq score (+ score (length x))) 920 (ignore "intersection"))
915 (ignore "intersection")) 921 (t ;; nope.
916 (t ;; nope. 922 (setq next t score -10) (ignore "collision")) ))
917 (setq next t score -10) (ignore "collision")) )) 923 (if (> score face-score)
918 (if (> score face-score) 924 (progn
919 (progn 925 (setq face-match face-attrs
920 (setq face-match face-attrs 926 face-score score )
921 face-score score ) 927 (ignore "%d << %S/%S" score face-class class))
922 (ignore "%d << %S/%S" score face-class class)) 928 (ignore "--- %d ---- (insufficient)" score)) ))
923 (ignore "--- %d ---- (insufficient)" score)) )) 929 ;; matched ? last attrs : nil
924 ;; matched ? last attrs : nil 930 (if face-match
925 (if face-match 931 (if (listp (car face-match)) (car face-match) face-match)
926 (if (listp (car face-match)) (car face-match) face-match) nil)) 932 nil))
927 ;; Unfortunately the default face returns a 933 ;; Unfortunately the default face returns a
928 ;; :background. Fortunately we can remove it, but how do we do 934 ;; :background. Fortunately we can remove it, but how do we do
929 ;; that in a non-system specific way? 935 ;; that in a non-system specific way?
930 (let ((spec (face-attr-construct face)) 936 (let ((spec (face-attr-construct face))
931 (new-spec nil)) 937 (new-spec nil))
932 (if (not (memq :background spec)) 938 (if (not (memq :background spec))
933 spec 939 spec
934 (while spec 940 (while spec
935 (let ((a (nth 0 spec)) 941 (let ((a (nth 0 spec))
936 (b (nth 1 spec))) 942 (b (nth 1 spec)))
937 (unless (and (eq a :background) 943 (unless (and (eq a :background)
938 (stringp b) 944 (stringp b)
939 (string= b "SystemWindow")) 945 (string= b "SystemWindow"))
940 (setq new-spec (cons a (cons b new-spec))))) 946 (setq new-spec (cons a (cons b new-spec)))))
941 (setq spec (cddr spec))) 947 (setq spec (cddr spec)))
942 new-spec)) )) 948 new-spec)))))
943 (if (or (memq :inherit face-spec) (eq 'default face)) 949 (if (or (memq :inherit face-spec) (eq 'default face))
944 face-spec 950 face-spec
945 (nconc face-spec (list :inherit 'default))) )) 951 (nconc face-spec (list :inherit 'default))) ))
@@ -988,21 +994,21 @@ merged by the user - `hfy-flatten-style' should do this."
988 (hfy-face-to-style-i 994 (hfy-face-to-style-i
989 (hfy-face-attr-for-class v hfy-display-class)) )))) 995 (hfy-face-attr-for-class v hfy-display-class)) ))))
990 (setq this 996 (setq this
991 (if val (cond 997 (if val (case key
992 ((eq key :family ) (hfy-family val)) 998 (:family (hfy-family val))
993 ((eq key :width ) (hfy-width val)) 999 (:width (hfy-width val))
994 ((eq key :weight ) (hfy-weight val)) 1000 (:weight (hfy-weight val))
995 ((eq key :slant ) (hfy-slant val)) 1001 (:slant (hfy-slant val))
996 ((eq key :foreground ) (hfy-colour val)) 1002 (:foreground (hfy-colour val))
997 ((eq key :background ) (hfy-bgcol val)) 1003 (:background (hfy-bgcol val))
998 ((eq key :box ) (hfy-box val)) 1004 (:box (hfy-box val))
999 ((eq key :height ) (hfy-size val)) 1005 (:height (hfy-size val))
1000 ((eq key :underline ) (hfy-decor key val)) 1006 (:underline (hfy-decor key val))
1001 ((eq key :overline ) (hfy-decor key val)) 1007 (:overline (hfy-decor key val))
1002 ((eq key :strike-through) (hfy-decor key val)) 1008 (:strike-through (hfy-decor key val))
1003 ((eq key :invisible ) (hfy-invisible val)) 1009 (:invisible (hfy-invisible val))
1004 ((eq key :bold ) (hfy-weight 'bold)) 1010 (:bold (hfy-weight 'bold))
1005 ((eq key :italic ) (hfy-slant 'italic)))))) 1011 (:italic (hfy-slant 'italic))))))
1006 (setq that (hfy-face-to-style-i next)) 1012 (setq that (hfy-face-to-style-i next))
1007 ;;(lwarn t :warning "%S => %S" fn (nconc this that parent)) 1013 ;;(lwarn t :warning "%S => %S" fn (nconc this that parent))
1008 (nconc this that parent))) ) 1014 (nconc this that parent))) )
@@ -1032,13 +1038,12 @@ haven\'t encountered them yet. Returns a `hfy-style-assoc'."
1032 (m (list 1)) 1038 (m (list 1))
1033 (x nil) 1039 (x nil)
1034 (r nil)) 1040 (r nil))
1035 (mapc 1041 (dolist (css style)
1036 (lambda (css) 1042 (if (string= (car css) "font-size")
1037 (if (string= (car css) "font-size") 1043 (progn
1038 (progn 1044 (when (not x) (setq m (nconc m (hfy-size-to-int (cdr css)))))
1039 (when (not x) (setq m (nconc m (hfy-size-to-int (cdr css))))) 1045 (when (string-match "pt" (cdr css)) (setq x t)))
1040 (when (string-match "pt" (cdr css)) (setq x t))) 1046 (setq r (nconc r (list css)))))
1041 (setq r (nconc r (list css))) )) style)
1042 ;;(message "r: %S" r) 1047 ;;(message "r: %S" r)
1043 (setq n (apply '* m)) 1048 (setq n (apply '* m))
1044 (nconc r (hfy-size (if x (round n) (* n 1.0)))) )) 1049 (nconc r (hfy-size (if x (round n) (* n 1.0)))) ))
@@ -1112,14 +1117,13 @@ See also: `hfy-face-to-style'"
1112 ;;(message "(hfy-face-to-style %S)" fn) 1117 ;;(message "(hfy-face-to-style %S)" fn)
1113 (setq css-list (hfy-face-to-style fn)) 1118 (setq css-list (hfy-face-to-style fn))
1114 (setq css-text 1119 (setq css-text
1115 (nconc 1120 (mapcar
1116 (mapcar 1121 (lambda (E)
1117 (lambda (E) 1122 (if (car E)
1118 (if (car E) 1123 (unless (member (car E) seen)
1119 (if (not (member (car E) seen)) 1124 (push (car E) seen)
1120 (progn 1125 (format " %s: %s; " (car E) (cdr E)))))
1121 (setq seen (cons (car E) seen)) 1126 css-list))
1122 (format " %s: %s; " (car E) (cdr E)))))) css-list)))
1123 (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) ) 1127 (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) )
1124 1128
1125;; extract a face from a list of char properties, if there is one: 1129;; extract a face from a list of char properties, if there is one:
@@ -1149,9 +1153,8 @@ property, or nil."
1149 (let* ((category (plist-get props 'category)) 1153 (let* ((category (plist-get props 'category))
1150 (face (when category (plist-get (symbol-plist category) 'face)))) 1154 (face (when category (plist-get (symbol-plist category) 'face))))
1151 face) 1155 face)
1152 (if font-lock-face 1156 (or font-lock-face
1153 font-lock-face 1157 face)))))
1154 face)))))
1155 1158
1156;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1159;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1157;; (defun hfy-get-face-at (pos) 1160;; (defun hfy-get-face-at (pos)
@@ -1200,11 +1203,10 @@ POINT is the point inside the invisible region.
1200MAP is the invisibility map as returned by `hfy-find-invisible-ranges'." 1203MAP is the invisibility map as returned by `hfy-find-invisible-ranges'."
1201 ;;(message "(hfy-invisible-name %S %S)" point map) 1204 ;;(message "(hfy-invisible-name %S %S)" point map)
1202 (let (name) 1205 (let (name)
1203 (mapc 1206 (dolist (range map)
1204 (lambda (range) 1207 (when (and (>= point (car range))
1205 (when (and (>= point (car range)) 1208 (< point (cdr range)))
1206 (< point (cdr range))) 1209 (setq name (format "invisible-%S-%S" (car range) (cdr range)))))
1207 (setq name (format "invisible-%S-%S" (car range) (cdr range))))) map)
1208 name)) 1210 name))
1209 1211
1210;; Fix-me: This function needs some cleanup by someone who understand 1212;; Fix-me: This function needs some cleanup by someone who understand
@@ -1221,137 +1223,137 @@ return a defface style list of face properties instead of a face symbol."
1221 ;;(message "hfy-face-at");;DBUG 1223 ;;(message "hfy-face-at");;DBUG
1222 ;; Fix-me: clean up, remove face-name etc 1224 ;; Fix-me: clean up, remove face-name etc
1223 ;; not sure why we'd want to remove face-name? -- v 1225 ;; not sure why we'd want to remove face-name? -- v
1224 (let ((overlay-data nil) 1226 (let ((overlay-data nil)
1225 (base-face nil) 1227 (base-face nil)
1226 ;; restored hfy-p-to-face as it handles faces like (bold) as 1228 ;; restored hfy-p-to-face as it handles faces like (bold) as
1227 ;; well as face like 'bold - hfy-get-face-at doesn't dtrt -- v 1229 ;; well as face like 'bold - hfy-get-face-at doesn't dtrt -- v
1228 (face-name (hfy-p-to-face (text-properties-at p))) 1230 (face-name (hfy-p-to-face (text-properties-at p)))
1229 ;; (face-name (hfy-get-face-at p)) 1231 ;; (face-name (hfy-get-face-at p))
1230 (prop-seen nil) 1232 (prop-seen nil)
1231 (extra-props nil) 1233 (extra-props nil)
1232 (text-props (text-properties-at p))) 1234 (text-props (text-properties-at p)))
1233 ;;(message "face-name: %S" face-name) 1235 ;;(message "face-name: %S" face-name)
1234 (when (and face-name (listp face-name) (facep (car face-name))) 1236 (when (and face-name (listp face-name) (facep (car face-name)))
1235 ;;(message "face-name is a list %S" face-name) 1237 ;;(message "face-name is a list %S" face-name)
1236 ;;(setq text-props (cons 'face face-name)) 1238 ;;(setq text-props (cons 'face face-name))
1237 (dolist (f face-name) 1239 (dolist (f face-name)
1238 (if (listp f) ;; for things like (variable-pitch (:foreground "red")) 1240 (setq extra-props (if (listp f)
1239 (setq extra-props (cons f extra-props)) 1241 ;; for things like (variable-pitch
1240 (setq extra-props (cons :inherit (cons f extra-props))))) 1242 ;; (:foreground "red"))
1241 (setq base-face (car face-name) 1243 (cons f extra-props)
1242 face-name nil)) 1244 (cons :inherit (cons f extra-props)))))
1243 ;; text-properties-at => (face (:foreground "red" ...)) 1245 (setq base-face (car face-name)
1244 ;; or => (face (compilation-info underline)) list of faces 1246 face-name nil))
1245 ;; overlay-properties 1247 ;; text-properties-at => (face (:foreground "red" ...))
1246 ;; format= (evaporate t face ((foreground-color . "red"))) 1248 ;; or => (face (compilation-info underline)) list of faces
1247 1249 ;; overlay-properties
1248 ;; SO: if we have turned overlays off, 1250 ;; format= (evaporate t face ((foreground-color . "red")))
1249 ;; or if there's no overlay data 1251
1250 ;; just bail out and return whatever face data we've accumulated so far 1252 ;; SO: if we have turned overlays off,
1251 (if (or (not (hfy-opt 'keep-overlays)) 1253 ;; or if there's no overlay data
1252 (not (setq overlay-data (hfy-overlay-props-at p)))) 1254 ;; just bail out and return whatever face data we've accumulated so far
1253 (progn 1255 (if (or (not (hfy-opt 'keep-overlays))
1254 ;;(message "· %d: %s; %S; %s" 1256 (not (setq overlay-data (hfy-overlay-props-at p))))
1255 ;; p face-name extra-props text-props) 1257 (progn
1256 (or face-name base-face)) ;; no overlays or extra properties 1258 ;;(message %d: %s; %S; %s"
1257 ;; collect any face data and any overlay data for processing: 1259 ;; p face-name extra-props text-props)
1258 (when text-props 1260 (or face-name base-face)) ;; no overlays or extra properties
1259 (setq overlay-data (cons text-props overlay-data))) 1261 ;; collect any face data and any overlay data for processing:
1260 (setq overlay-data (nreverse overlay-data)) 1262 (when text-props
1261 ;;(message "- %d: %s; %S; %s; %s" 1263 (push text-props overlay-data))
1262 ;; p face-name extra-props text-props overlay-data) 1264 (setq overlay-data (nreverse overlay-data))
1263 ;; remember the basic face name so we don't keep repeating its specs: 1265 ;;(message "- %d: %s; %S; %s; %s"
1264 (when face-name (setq base-face face-name)) 1266 ;; p face-name extra-props text-props overlay-data)
1265 (mapc 1267 ;; remember the basic face name so we don't keep repeating its specs:
1266 (lambda (P) 1268 (when face-name (setq base-face face-name))
1267 (let ((iprops (cadr (memq 'invisible P)))) 1269 (dolist (P overlay-data)
1268 ;;(message "(hfy-prop-invisible-p %S)" iprops) 1270 (let ((iprops (cadr (memq 'invisible P)))) ;FIXME: plist-get?
1269 (when (and iprops (hfy-prop-invisible-p iprops)) 1271 ;;(message "(hfy-prop-invisible-p %S)" iprops)
1270 (setq extra-props 1272 (when (and iprops (hfy-prop-invisible-p iprops))
1271 (cons :invisible (cons t extra-props))) )) 1273 (setq extra-props
1272 (let ((fprops (cadr (or (memq 'face P) 1274 (cons :invisible (cons t extra-props))) ))
1273 (memq 'font-lock-face P))))) 1275 (let ((fprops (cadr (or (memq 'face P)
1274 ;;(message "overlay face: %s" fprops) 1276 (memq 'font-lock-face P)))))
1275 (if (not (listp fprops)) 1277 ;;(message "overlay face: %s" fprops)
1276 (let ((this-face (if (stringp fprops) (intern fprops) fprops))) 1278 (if (not (listp fprops))
1277 (when (not (eq this-face base-face)) 1279 (let ((this-face (if (stringp fprops) (intern fprops) fprops)))
1278 (setq extra-props 1280 (when (not (eq this-face base-face))
1279 (cons :inherit 1281 (setq extra-props
1280 (cons this-face extra-props))) )) 1282 (cons :inherit
1281 (while fprops 1283 (cons this-face extra-props))) ))
1282 (if (facep (car fprops)) 1284 (while fprops
1283 (let ((face (car fprops))) 1285 (if (facep (car fprops))
1284 (when (stringp face) (setq face (intern fprops))) 1286 (let ((face (car fprops)))
1285 (setq extra-props 1287 (when (stringp face) (setq face (intern fprops)))
1286 (cons :inherit 1288 (setq extra-props
1287 (cons face 1289 (cons :inherit
1288 extra-props))) 1290 (cons face
1289 (setq fprops (cdr fprops))) 1291 extra-props)))
1290 (let (p v) 1292 (setq fprops (cdr fprops)))
1291 ;; Sigh. 1293 (let (p v)
1292 (if (listp (car fprops)) 1294 ;; Sigh.
1293 (if (nlistp (cdr (car fprops))) 1295 (if (listp (car fprops))
1294 (progn 1296 (if (nlistp (cdr (car fprops)))
1295 ;; ((prop . val)) 1297 (progn
1296 (setq p (caar fprops)) 1298 ;; ((prop . val))
1297 (setq v (cdar fprops)) 1299 (setq p (caar fprops))
1298 (setq fprops (cdr fprops))) 1300 (setq v (cdar fprops))
1299 ;; ((prop val)) 1301 (setq fprops (cdr fprops)))
1300 (setq p (caar fprops)) 1302 ;; ((prop val))
1301 (setq v (cadar fprops)) 1303 (setq p (caar fprops))
1302 (setq fprops (cdr fprops))) 1304 (setq v (cadar fprops))
1303 (if (listp (cdr fprops)) 1305 (setq fprops (cdr fprops)))
1304 (progn 1306 (if (listp (cdr fprops))
1305 ;; (:prop val :prop val ...) 1307 (progn
1306 (setq p (car fprops)) 1308 ;; (:prop val :prop val ...)
1307 (setq v (cadr fprops)) 1309 (setq p (car fprops))
1308 (setq fprops (cddr fprops))) 1310 (setq v (cadr fprops))
1309 (if (and (listp fprops) 1311 (setq fprops (cddr fprops)))
1310 (not (listp (cdr fprops)))) 1312 (if (and (listp fprops)
1311 ;;(and (consp x) (cdr (last x))) 1313 (not (listp (cdr fprops))))
1312 (progn 1314 ;;(and (consp x) (cdr (last x)))
1313 ;; (prop . val) 1315 (progn
1314 (setq p (car fprops)) 1316 ;; (prop . val)
1315 (setq v (cdr fprops)) 1317 (setq p (car fprops))
1316 (setq fprops nil)) 1318 (setq v (cdr fprops))
1317 (error "Eh... another format! fprops=%s" fprops) ))) 1319 (setq fprops nil))
1318 (setq p (case p 1320 (error "Eh... another format! fprops=%s" fprops) )))
1319 ;; These are all the properties handled 1321 (setq p (case p
1320 ;; in `hfy-face-to-style-i'. 1322 ;; These are all the properties handled
1321 ;; 1323 ;; in `hfy-face-to-style-i'.
1322 ;; Are these translations right? 1324 ;;
1323 ;; yes, they are -- v 1325 ;; Are these translations right?
1324 ('family :family ) 1326 ;; yes, they are -- v
1325 ('width :width ) 1327 (family :family )
1326 ('height :height ) 1328 (width :width )
1327 ('weight :weight ) 1329 (height :height )
1328 ('slant :slant ) 1330 (weight :weight )
1329 ('underline :underline ) 1331 (slant :slant )
1330 ('overline :overline ) 1332 (underline :underline )
1331 ('strike-through :strike-through) 1333 (overline :overline )
1332 ('box :box ) 1334 (strike-through :strike-through)
1333 ('foreground-color :foreground) 1335 (box :box )
1334 ('background-color :background) 1336 (foreground-color :foreground)
1335 ('bold :bold ) 1337 (background-color :background)
1336 ('italic :italic ) 1338 (bold :bold )
1337 (t p))) 1339 (italic :italic )
1338 (if (memq p prop-seen) nil ;; noop 1340 (t p)))
1339 (setq prop-seen (cons p prop-seen) 1341 (if (memq p prop-seen) nil ;; noop
1340 extra-props (cons p (cons v extra-props)))) )))))) 1342 (setq prop-seen (cons p prop-seen)
1341 overlay-data) 1343 extra-props (cons p (cons v extra-props))))))))))
1342 ;;(message "+ %d: %s; %S" p face-name extra-props) 1344 ;;(message "+ %d: %s; %S" p face-name extra-props)
1343 (if extra-props 1345 (if extra-props
1344 (if (listp face-name) 1346 (if (listp face-name)
1345 (nconc extra-props face-name) 1347 (nconc extra-props face-name)
1346 (nconc extra-props (face-attr-construct face-name))) 1348 (nconc extra-props (face-attr-construct face-name)))
1347 face-name)) )) 1349 face-name)) ))
1348 1350
1349(defun hfy-overlay-props-at (p) 1351(defun hfy-overlay-props-at (p)
1350 "Grab overlay properties at point P. 1352 "Grab overlay properties at point P.
1351The plists are returned in descending priority order." 1353The plists are returned in descending priority order."
1352 (sort (mapcar (lambda (O) (overlay-properties O)) (overlays-at p)) 1354 (sort (mapcar #'overlay-properties (overlays-at p))
1353 (lambda (A B) (> (or (cadr (memq 'priority A)) 0) 1355 (lambda (A B) (> (or (cadr (memq 'priority A)) 0) ;FIXME: plist-get?
1354 (or (cadr (memq 'priority B)) 0)) ) ) ) 1356 (or (cadr (memq 'priority B)) 0)))))
1355 1357
1356;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements: 1358;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements:
1357(defun hfy-compile-stylesheet () 1359(defun hfy-compile-stylesheet ()
@@ -1366,9 +1368,9 @@ The plists are returned in descending priority order."
1366 (goto-char pt) 1368 (goto-char pt)
1367 (while (< pt (point-max)) 1369 (while (< pt (point-max))
1368 (if (and (setq fn (hfy-face-at pt)) (not (assoc fn style))) 1370 (if (and (setq fn (hfy-face-at pt)) (not (assoc fn style)))
1369 (setq style (cons (cons fn (hfy-face-to-css fn)) style))) 1371 (push (cons fn (hfy-face-to-css fn)) style))
1370 (setq pt (next-char-property-change pt))) ) 1372 (setq pt (next-char-property-change pt))) )
1371 (setq style (cons (cons 'default (hfy-face-to-css 'default)) style))) ) 1373 (push (cons 'default (hfy-face-to-css 'default)) style)))
1372 1374
1373(defun hfy-fontified-p () 1375(defun hfy-fontified-p ()
1374 "`font-lock' doesn't like to say it\'s been fontified when in batch 1376 "`font-lock' doesn't like to say it\'s been fontified when in batch
@@ -1410,8 +1412,8 @@ Returns a modified copy of FACE-MAP."
1410 (span-stop nil) 1412 (span-stop nil)
1411 (span-start nil) 1413 (span-start nil)
1412 (reduced-map nil)) 1414 (reduced-map nil))
1413 ;;(setq reduced-map (cons (car tmp-map) reduced-map)) 1415 ;;(push (car tmp-map) reduced-map)
1414 ;;(setq reduced-map (cons (cadr tmp-map) reduced-map)) 1416 ;;(push (cadr tmp-map) reduced-map)
1415 (while tmp-map 1417 (while tmp-map
1416 (setq first-start (cadddr tmp-map) 1418 (setq first-start (cadddr tmp-map)
1417 first-stop (caddr tmp-map) 1419 first-stop (caddr tmp-map)
@@ -1431,8 +1433,8 @@ Returns a modified copy of FACE-MAP."
1431 first-stop (caddr map-buf) 1433 first-stop (caddr map-buf)
1432 last-start (cadr map-buf) 1434 last-start (cadr map-buf)
1433 last-stop (car map-buf))) 1435 last-stop (car map-buf)))
1434 (setq reduced-map (cons span-stop reduced-map)) 1436 (push span-stop reduced-map)
1435 (setq reduced-map (cons span-start reduced-map)) 1437 (push span-start reduced-map)
1436 (setq tmp-map (memq last-start tmp-map)) 1438 (setq tmp-map (memq last-start tmp-map))
1437 (setq tmp-map (cdr tmp-map))) 1439 (setq tmp-map (cdr tmp-map)))
1438 (setq reduced-map (nreverse reduced-map)))) 1440 (setq reduced-map (nreverse reduced-map))))
@@ -1459,15 +1461,15 @@ Returns a modified copy of FACE-MAP."
1459 (goto-char pt) 1461 (goto-char pt)
1460 (while (< pt (point-max)) 1462 (while (< pt (point-max))
1461 (if (setq fn (hfy-face-at pt)) 1463 (if (setq fn (hfy-face-at pt))
1462 (progn (if prev-tag (setq map (cons (cons pt-narrow 'end) map))) 1464 (progn (if prev-tag (push (cons pt-narrow 'end) map))
1463 (setq map (cons (cons pt-narrow fn) map)) 1465 (push (cons pt-narrow fn) map)
1464 (setq prev-tag t)) 1466 (setq prev-tag t))
1465 (if prev-tag (setq map (cons (cons pt-narrow 'end) map))) 1467 (if prev-tag (push (cons pt-narrow 'end) map))
1466 (setq prev-tag nil)) 1468 (setq prev-tag nil))
1467 (setq pt (next-char-property-change pt)) 1469 (setq pt (next-char-property-change pt))
1468 (setq pt-narrow (1+ (- pt (point-min))))) 1470 (setq pt-narrow (1+ (- pt (point-min)))))
1469 (if (and map (not (eq 'end (cdar map)))) 1471 (if (and map (not (eq 'end (cdar map))))
1470 (setq map (cons (cons (- (point-max) (point-min)) 'end) map)))) 1472 (push (cons (- (point-max) (point-min)) 'end) map)))
1471 (if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map))) 1473 (if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map)))
1472 1474
1473(defun hfy-buffer () 1475(defun hfy-buffer ()
@@ -1514,7 +1516,8 @@ Uses `hfy-link-style-fun' to do this."
1514 (format 1516 (format
1515 "span.%s %s\nspan.%s a %s\n" 1517 "span.%s %s\nspan.%s a %s\n"
1516 (cadr style) (cddr style) 1518 (cadr style) (cddr style)
1517 (cadr style) (hfy-link-style (cddr style)))) css)) 1519 (cadr style) (hfy-link-style (cddr style))))
1520 css))
1518 " --></style>\n")) 1521 " --></style>\n"))
1519 (funcall hfy-page-header file stylesheet))) 1522 (funcall hfy-page-header file stylesheet)))
1520 1523
@@ -1665,38 +1668,36 @@ FILE, if set, is the file name."
1665 ;; property has already served its main purpose by this point. 1668 ;; property has already served its main purpose by this point.
1666 ;;(message "mapcar over the CSS-MAP") 1669 ;;(message "mapcar over the CSS-MAP")
1667 (message "invis-ranges:\n%S" invis-ranges) 1670 (message "invis-ranges:\n%S" invis-ranges)
1668 (mapc 1671 (dolist (point-face css-map)
1669 (lambda (point-face) 1672 (let ((pt (car point-face))
1670 (let ((pt (car point-face)) 1673 (fn (cdr point-face))
1671 (fn (cdr point-face)) 1674 (move-link nil))
1672 (move-link nil)) 1675 (goto-char pt)
1673 (goto-char pt) 1676 (setq move-link
1674 (setq move-link 1677 (or (get-text-property pt 'hfy-linkp)
1675 (or (get-text-property pt 'hfy-linkp) 1678 (get-text-property pt 'hfy-endl )))
1676 (get-text-property pt 'hfy-endl ))) 1679 (if (eq 'end fn)
1677 (if (eq 'end fn) 1680 (insert "</span>")
1678 (insert "</span>") 1681 (if (not (and srcdir file))
1679 (if (not (and srcdir file)) 1682 nil
1680 nil 1683 (when move-link
1681 (when move-link 1684 (remove-text-properties (point) (1+ (point)) '(hfy-endl nil))
1682 (remove-text-properties (point) (1+ (point)) '(hfy-endl nil)) 1685 (put-text-property pt (1+ pt) 'hfy-endl t) ))
1683 (put-text-property pt (1+ pt) 'hfy-endl t) )) 1686 ;; if we have invisible blocks, we need to do some extra magic:
1684 ;; if we have invisible blocks, we need to do some extra magic: 1687 (if invis-ranges
1685 (if invis-ranges 1688 (let ((iname (hfy-invisible-name pt invis-ranges))
1686 (let ((iname (hfy-invisible-name pt invis-ranges)) 1689 (fname (hfy-lookup fn css-sheet )))
1687 (fname (hfy-lookup fn css-sheet ))) 1690 (when (assq pt invis-ranges)
1688 (when (assq pt invis-ranges) 1691 (insert
1689 (insert 1692 (format "<span onclick=\"toggle_invis('%s');\">" iname))
1690 (format "<span onclick=\"toggle_invis('%s');\">" iname)) 1693 (insert "…</span>"))
1691 (insert "…</span>")) 1694 (insert
1692 (insert 1695 (format "<span class=\"%s\" id=\"%s-%d\">" fname iname pt)))
1693 (format "<span class=\"%s\" id=\"%s-%d\">" fname iname pt))) 1696 (insert (format "<span class=\"%s\">" (hfy-lookup fn css-sheet))))
1694 (insert (format "<span class=\"%s\">" (hfy-lookup fn css-sheet)))) 1697 (if (not move-link) nil
1695 (if (not move-link) nil 1698 ;;(message "removing prop2 @ %d" (point))
1696 ;;(message "removing prop2 @ %d" (point)) 1699 (if (remove-text-properties (point) (1+ (point)) '(hfy-endl nil))
1697 (if (remove-text-properties (point) (1+ (point)) '(hfy-endl nil)) 1700 (put-text-property pt (1+ pt) 'hfy-endl t))))))
1698 (put-text-property pt (1+ pt) 'hfy-endl t))) )))
1699 css-map)
1700 ;; ##################################################################### 1701 ;; #####################################################################
1701 ;; Invisibility 1702 ;; Invisibility
1702 ;; Maybe just make the text invisible in XHTML? 1703 ;; Maybe just make the text invisible in XHTML?
@@ -1724,13 +1725,13 @@ FILE, if set, is the file name."
1724 (if (not (setq pr (get-text-property pt lp))) nil 1725 (if (not (setq pr (get-text-property pt lp))) nil
1725 (goto-char pt) 1726 (goto-char pt)
1726 (remove-text-properties pt (1+ pt) (list lp nil)) 1727 (remove-text-properties pt (1+ pt) (list lp nil))
1727 (cond 1728 (case lp
1728 ((eq lp 'hfy-link) 1729 (hfy-link
1729 (if (setq rr (get-text-property pt 'hfy-inst)) 1730 (if (setq rr (get-text-property pt 'hfy-inst))
1730 (insert (format "<a name=\"%s\"></a>" rr))) 1731 (insert (format "<a name=\"%s\"></a>" rr)))
1731 (insert (format "<a href=\"%s\">" pr)) 1732 (insert (format "<a href=\"%s\">" pr))
1732 (setq lp 'hfy-endl)) 1733 (setq lp 'hfy-endl))
1733 ((eq lp 'hfy-endl) 1734 (hfy-endl
1734 (insert "</a>") (setq lp 'hfy-link)) ))) )) 1735 (insert "</a>") (setq lp 'hfy-link)) ))) ))
1735 1736
1736 ;; ##################################################################### 1737 ;; #####################################################################
@@ -1760,7 +1761,7 @@ FILE, if set, is the file name."
1760 1761
1761(defun hfy-force-fontification () 1762(defun hfy-force-fontification ()
1762 "Try to force font-locking even when it is optimised away." 1763 "Try to force font-locking even when it is optimised away."
1763 (mapc (lambda (fun) (funcall fun)) hfy-init-kludge-hooks) 1764 (run-hooks 'hfy-init-kludge-hook)
1764 (eval-and-compile (require 'font-lock)) 1765 (eval-and-compile (require 'font-lock))
1765 (if (boundp 'font-lock-cache-position) 1766 (if (boundp 'font-lock-cache-position)
1766 (or font-lock-cache-position 1767 (or font-lock-cache-position
@@ -1811,6 +1812,7 @@ hyperlinks as appropriate."
1811 "Return a list of files under DIRECTORY. 1812 "Return a list of files under DIRECTORY.
1812Strips any leading \"./\" from each filename." 1813Strips any leading \"./\" from each filename."
1813 ;;(message "hfy-list-files");;DBUG 1814 ;;(message "hfy-list-files");;DBUG
1815 ;; FIXME: this changes the dir of the currrent buffer. Is that right??
1814 (cd directory) 1816 (cd directory)
1815 (mapcar (lambda (F) (if (string-match "^./\\(.*\\)" F) (match-string 1 F) F)) 1817 (mapcar (lambda (F) (if (string-match "^./\\(.*\\)" F) (match-string 1 F) F))
1816 (split-string (shell-command-to-string hfy-find-cmd))) ) 1818 (split-string (shell-command-to-string hfy-find-cmd))) )
@@ -1995,7 +1997,7 @@ FILE is the specific file we are rendering."
1995 (rmap-line nil) 1997 (rmap-line nil)
1996 (tag-regex (hfy-word-regex TAG)) 1998 (tag-regex (hfy-word-regex TAG))
1997 (tag-map (gethash TAG cache-hash)) 1999 (tag-map (gethash TAG cache-hash))
1998 (tag-files (mapcar (lambda (X) (car X)) tag-map))) 2000 (tag-files (mapcar #'car tag-map)))
1999 ;; find instances of TAG and do what needs to be done: 2001 ;; find instances of TAG and do what needs to be done:
2000 (goto-char (point-min)) 2002 (goto-char (point-min))
2001 (while (search-forward TAG nil 'NOERROR) 2003 (while (search-forward TAG nil 'NOERROR)
@@ -2098,17 +2100,17 @@ FILE is the specific file we are rendering."
2098 (setq tag-point (round (string-to-number (match-string 3)))) 2100 (setq tag-point (round (string-to-number (match-string 3))))
2099 (setq hash-entry (gethash tag-string cache-hash)) 2101 (setq hash-entry (gethash tag-string cache-hash))
2100 (setq new-entry (list etags-file tag-line tag-point)) 2102 (setq new-entry (list etags-file tag-line tag-point))
2101 (setq hash-entry (cons new-entry hash-entry)) 2103 (push new-entry hash-entry)
2102 ;;(message "HASH-ENTRY %s %S" tag-string new-entry) 2104 ;;(message "HASH-ENTRY %s %S" tag-string new-entry)
2103 (puthash tag-string hash-entry cache-hash)))) ))) 2105 (puthash tag-string hash-entry cache-hash)))) )))
2104 2106
2105 ;; cache a list of tags in descending length order: 2107 ;; cache a list of tags in descending length order:
2106 (maphash (lambda (K V) (setq tags-list (cons K tags-list))) cache-hash) 2108 (maphash (lambda (K V) (push K tags-list)) cache-hash)
2107 (setq tags-list (sort tags-list (lambda (A B) (< (length B) (length A))))) 2109 (setq tags-list (sort tags-list (lambda (A B) (< (length B) (length A)))))
2108 2110
2109 ;; put the tag list into the cache: 2111 ;; put the tag list into the cache:
2110 (if tlist-cache (setcar (cdr tlist-cache) tags-list) 2112 (if tlist-cache (setcar (cdr tlist-cache) tags-list)
2111 (setq hfy-tags-sortl (cons (list srcdir tags-list) hfy-tags-sortl))) 2113 (push (list srcdir tags-list) hfy-tags-sortl))
2112 2114
2113 ;; return the number of tags found: 2115 ;; return the number of tags found:
2114 (length tags-list) )) 2116 (length tags-list) ))
@@ -2134,36 +2136,33 @@ DSTDIR is the output directory, where files will be written."
2134 (setq cache-hash (cadr cache-entry)) 2136 (setq cache-hash (cadr cache-entry))
2135 (setq index-buf (get-buffer-create index-file)))) 2137 (setq index-buf (get-buffer-create index-file))))
2136 nil ;; noop 2138 nil ;; noop
2137 (maphash (lambda (K V) (setq tag-list (cons K tag-list))) cache-hash) 2139 (maphash (lambda (K V) (push K tag-list)) cache-hash)
2138 (setq tag-list (sort tag-list 'string<)) 2140 (setq tag-list (sort tag-list 'string<))
2139 (set-buffer index-buf) 2141 (set-buffer index-buf)
2140 (erase-buffer) 2142 (erase-buffer)
2141 (insert (funcall hfy-page-header filename "<!-- CSS -->")) 2143 (insert (funcall hfy-page-header filename "<!-- CSS -->"))
2142 (insert "<table class=\"index\">\n") 2144 (insert "<table class=\"index\">\n")
2143 2145
2144 (mapc 2146 (dolist (TAG tag-list)
2145 (lambda (TAG) 2147 (let ((tag-started nil))
2146 (let ((tag-started nil)) 2148 (dolist (DEF (gethash TAG cache-hash))
2147 (mapc 2149 (if (and stub (not (string-match (concat "^" stub) TAG)))
2148 (lambda (DEF) 2150 nil ;; we have a stub and it didn't match: NOOP
2149 (if (and stub (not (string-match (concat "^" stub) TAG))) 2151 (let ((file (car DEF))
2150 nil ;; we have a stub and it didn't match: NOOP 2152 (line (cadr DEF)))
2151 (let ((file (car DEF)) 2153 (insert
2152 (line (cadr DEF))) 2154 (format
2153 (insert 2155 (concat
2154 (format 2156 " <tr> \n"
2155 (concat 2157 " <td>%s</td> \n"
2156 " <tr> \n" 2158 " <td><a href=\"%s%s\">%s</a></td> \n"
2157 " <td>%s</td> \n" 2159 " <td><a href=\"%s%s#%s.%d\">%d</a></td>\n"
2158 " <td><a href=\"%s%s\">%s</a></td> \n" 2160 " </tr> \n")
2159 " <td><a href=\"%s%s#%s.%d\">%d</a></td>\n" 2161 (if (string= TAG tag-started) "&nbsp;"
2160 " </tr> \n") 2162 (format "<a name=\"%s\">%s</a>" TAG TAG))
2161 (if (string= TAG tag-started) "&nbsp;" 2163 file (or hfy-link-extn hfy-extn) file
2162 (format "<a name=\"%s\">%s</a>" TAG TAG)) 2164 file (or hfy-link-extn hfy-extn) TAG line line))
2163 file (or hfy-link-extn hfy-extn) file 2165 (setq tag-started TAG))))))
2164 file (or hfy-link-extn hfy-extn) TAG line line))
2165 (setq tag-started TAG))))
2166 (gethash TAG cache-hash)))) tag-list)
2167 (insert "</table>\n") 2166 (insert "</table>\n")
2168 (insert (funcall hfy-page-footer filename)) 2167 (insert (funcall hfy-page-footer filename))
2169 (and dstdir (cd dstdir)) 2168 (and dstdir (cd dstdir))
@@ -2237,20 +2236,15 @@ See: `hfy-tags-cache' and `hfy-tags-rmap'"
2237 (fwd-map (cadr (assoc srcdir hfy-tags-cache))) 2236 (fwd-map (cadr (assoc srcdir hfy-tags-cache)))
2238 (rev-map (cadr (assoc srcdir hfy-tags-rmap ))) 2237 (rev-map (cadr (assoc srcdir hfy-tags-rmap )))
2239 (taglist (cadr (assoc srcdir hfy-tags-sortl)))) 2238 (taglist (cadr (assoc srcdir hfy-tags-sortl))))
2240 (mapc 2239 (dolist (TAG taglist)
2241 (lambda (TAG) 2240 (setq def-list (gethash TAG fwd-map)
2242 (setq def-list (gethash TAG fwd-map) 2241 old-list (gethash TAG rev-map)
2243 old-list (gethash TAG rev-map) 2242 exc-list (mapcar (lambda (P) (list (car P) (cadr P))) def-list)
2244 new-list nil 2243 new-list nil)
2245 exc-list nil) 2244 (dolist (P old-list)
2246 (mapc 2245 (or (member (list (car P) (cadr P)) exc-list)
2247 (lambda (P) 2246 (push P new-list)))
2248 (setq exc-list (cons (list (car P) (cadr P)) exc-list))) def-list) 2247 (puthash TAG new-list rev-map))))
2249 (mapc
2250 (lambda (P)
2251 (or (member (list (car P) (cadr P)) exc-list)
2252 (setq new-list (cons P new-list)))) old-list)
2253 (puthash TAG new-list rev-map)) taglist) ))
2254 2248
2255(defun htmlfontify-run-etags (srcdir) 2249(defun htmlfontify-run-etags (srcdir)
2256 "Load the etags cache for SRCDIR. 2250 "Load the etags cache for SRCDIR.
@@ -2264,11 +2258,11 @@ See `hfy-load-tags-cache'."
2264;; (message "foo: %S\nbar: %S" foo bar)) 2258;; (message "foo: %S\nbar: %S" foo bar))
2265 2259
2266(defun hfy-save-kill-buffers (buffer-list &optional dstdir) 2260(defun hfy-save-kill-buffers (buffer-list &optional dstdir)
2267 (mapc (lambda (B) 2261 (dolist (B buffer-list)
2268 (set-buffer B) 2262 (set-buffer B)
2269 (and dstdir (file-directory-p dstdir) (cd dstdir)) 2263 (and dstdir (file-directory-p dstdir) (cd dstdir))
2270 (save-buffer) 2264 (save-buffer)
2271 (kill-buffer B)) buffer-list) ) 2265 (kill-buffer B)))
2272 2266
2273(defun htmlfontify-copy-and-link-dir (srcdir dstdir &optional f-ext l-ext) 2267(defun htmlfontify-copy-and-link-dir (srcdir dstdir &optional f-ext l-ext)
2274 "Trawl SRCDIR and write fontified-and-hyperlinked output in DSTDIR. 2268 "Trawl SRCDIR and write fontified-and-hyperlinked output in DSTDIR.
@@ -2291,8 +2285,8 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'."
2291 (clrhash (cadr tr-cache)) 2285 (clrhash (cadr tr-cache))
2292 (hfy-make-directory dstdir) 2286 (hfy-make-directory dstdir)
2293 (setq source-files (hfy-list-files srcdir)) 2287 (setq source-files (hfy-list-files srcdir))
2294 (mapc (lambda (file) 2288 (dolist (file source-files)
2295 (hfy-copy-and-fontify-file srcdir dstdir file)) source-files) 2289 (hfy-copy-and-fontify-file srcdir dstdir file))
2296 (hfy-subtract-maps srcdir) 2290 (hfy-subtract-maps srcdir)
2297 (hfy-save-kill-buffers (hfy-prepare-index srcdir dstdir) dstdir) 2291 (hfy-save-kill-buffers (hfy-prepare-index srcdir dstdir) dstdir)
2298 (hfy-save-kill-buffers (hfy-prepare-tag-map srcdir dstdir) dstdir) )) 2292 (hfy-save-kill-buffers (hfy-prepare-tag-map srcdir dstdir) dstdir) ))
@@ -2345,8 +2339,11 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'."
2345 (custom-save-delete 'hfy-init-progn) 2339 (custom-save-delete 'hfy-init-progn)
2346 (setq start-pos (point)) 2340 (setq start-pos (point))
2347 (princ "(hfy-init-progn\n;;auto-generated, only one copy allowed\n") 2341 (princ "(hfy-init-progn\n;;auto-generated, only one copy allowed\n")
2342 ;; FIXME: This saving&restoring of global customization
2343 ;; variables can interfere with other customization settings for
2344 ;; those vars (in .emacs or in Customize).
2348 (mapc 'hfy-save-initvar 2345 (mapc 'hfy-save-initvar
2349 (list 'auto-mode-alist 'interpreter-mode-alist)) 2346 '(auto-mode-alist interpreter-mode-alist))
2350 (princ ")\n") 2347 (princ ")\n")
2351 (indent-region start-pos (point) nil)) 2348 (indent-region start-pos (point) nil))
2352 (custom-save-all) )) 2349 (custom-save-all) ))