Function: hfy-face-at
hfy-face-at is a byte-compiled function defined in htmlfontify.el.gz.
Signature
(hfy-face-at P)
Documentation
Find face in effect at point P.
If overlays are to be considered (see hfy-optimizations) then this may
return a defface style list of face properties instead of a face symbol.
Source Code
;; Defined in /usr/src/emacs/lisp/htmlfontify.el.gz
;; 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.
If overlays are to be considered (see `hfy-optimizations') then this may
return a `defface' style list of face properties instead of a face symbol."
;;(message "hfy-face-at");;DBUG
;; Fix-me: clean up, remove face-name etc
;; not sure why we'd want to remove face-name? -- v
(let ((overlay-data nil)
(base-face nil)
(face-name (get-text-property p 'face))
;; (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 "(invisible-p %S)" iprops)
(when (and iprops (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 (cl-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
(nconc extra-props (if (listp face-name)
face-name
(face-attr-construct face-name)))
face-name)) ))