Core package offering - engrave-faces.el

[Timothy]

Hi All,

Over the last few months I have worked on a package that I think may be
a good candidate for inclusion into Emacs. It has recently reached what
I consider a sufficient quality for consideration - though I anticipate
that should this be seen as promising there will likely be suggested
improvements.

This has been motivated by a desire to produce a better method of
formatting Org source blocks in PDF export, and inspired by htmlize.

Unlike htmlize, Engrave Faces provides general functionality to
transform a buffer into another format with font-lock information.
This core functionality is currently made us of in
engrave-faces-latex.el, engrave-faces-ansi.el, and engrave-faces-html.el
to provide exporters for LaTeX, ASCII/ANSI, and HTML.

Compared to htmlize and htmlfontify.el, Engrave Faces currently lacks
the ability to treat links specially, or properly handle the text
transformation performed by overlays*. However, this is also much smaller
and hopefully more maintainable.
- engrave-faces.el is 250 sloc
- engrave-faces-latex.el is 100 sloc
- engrave-faces-ansi.el is 140 sloc
- engrave-faces-html.el is 115 sloc
( *there may be other differences, but this is what's apparent to me. )

For comparison, htmlize.el is 1700 sloc and htmlfontify.el is 2200 sloc.

Engrave Faces also possesses the unique capability that it can be given
a list of preset face styles which will override the current attributes
of those faces. These overrides are also passed down with inheritance,
via an internal expansion and merging of face attribute information.
This allows one to save the details for a certain theme, and "engrave"
the buffer with font-lock attributes from that theme regardless of what
the current theme is. For ease of applying this to with your current
theme a function `engrave-faces-generate-preset' is provided which
re-generates the saved face information using the current theme.

I feel that this is likely generally useful functionality, and so would
like to offer it to Emacs to make it more accessible and more visible
for improvement.

I am currently an FSF-assigned contributor to Org mode, and assume that
this should make contributing to Emacs fairly straightforward.

Attached you may find the engrave-faces{,-latex,-ansi,-html}.el as well
as LaTeX, ASCII/ANSI, and HTML versions of engrave-faces.el for sampling.
The code is also available at https://github.com/tecosaur/engrave-faces.

All the best,

--
Timothy

p.s. I am not subscribed to this list, so please include my address in replies.

engrave-faces.el
Description: Text Data

engrave-faces-latex.el
Description: Text Data

engrave-faces-ansi.el
Description: Text Data

engrave-faces-html.el
Description: Text Data

engrave-faces.el.tex
Description: Text Data

engrave-faces.el.txt
Description: Text document

;;; engrave-faces.el --- Convert font-lock faces to other formats -*- lexical-binding: t; -*-

;; Copyright (C) 2021 TEC

;; Author: TEC <https://github/tecosaur>
;; Maintainer: TEC <tec@tecosaur.com>
;; Created: January 18, 2021
;; Modified: July 10, 2021
;; Version: 0.1.0
;; Keywords: faces
;; Homepage: https://github.com/tecosaur/engrave-faces
;; Package-Requires: ((emacs "27.1"))

;;; License:

;; This file is part of engrave-faces, which is not part of GNU Emacs.
;;
;; engrave-faces 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.
;;
;; engrave-faces 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 engrave-faces.  If not, see <https://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: GPL-3.0-or-later

;;; Commentary:

;;  Convert font-lock faces to other formats.

;;; Code:

(require 'map)

;;;###autoload
(defvar engrave-faces--backends nil)

;;;###autoload
(defmacro engrave-faces-define-backend (name extension face-transformer &optional standalone-transformer view-setup)
  `(progn (add-to-list 'engrave-faces--backends
                       (list ,name :face-transformer ,face-transformer :extension ,extension))
          (defun ,(intern (concat "engrave-faces-" name "-buffer")) (&optional switch-to-result)
            ,(concat "Convert buffer to " name " formatting.")
            (interactive '(t))
            (let ((buf (engrave-faces-buffer ,name)))
              (when switch-to-result
                (switch-to-buffer buf)
                ,(when view-setup `(funcall ,view-setup)))
              buf))
          ,(when standalone-transformer
             `(defun ,(intern (concat "engrave-faces-" name "-buffer-standalone")) (&optional switch-to-result)
                (interactive '(t))
                ,(concat "Export the current buffer to a standalone " name " buffer.")
                (let ((buf (engrave-faces-buffer ,name)))
                  (with-current-buffer buf
                    (funcall ,standalone-transformer))
                  (when switch-to-result
                    (switch-to-buffer buf)
                    ,(when view-setup `(funcall ,view-setup)))
                  buf)))
          (defvar ,(intern (concat "engrave-faces-" name "-before-hook")) nil)
          (defvar ,(intern (concat "engrave-faces-" name "-after-hook")) nil)))

(defgroup engrave-faces nil
  "Export buffers with font-lock information to other formats."
  :group 'hypermedia)

(defcustom engrave-faces-attributes-of-interest
  '(:foreground :background :slant :weight :height :strike-through)
  "Attributes which sould be paid attention to."
  :type '(repeat symbol)
  :group 'engrave-faces)

(defcustom engrave-faces-before-hook nil
  "Hook run before engraving a buffer.
The hook functions are run in the source buffer (not the resulting buffer)."
  :type 'hook
  :group 'engrave-faces)

(defcustom engrave-faces-after-hook nil
  "Hook run after engraving a buffer.
Unlike `engrave-faces-before-hook', these functions are run in the generated
buffer.  You may use them to modify the outlook of the final output."
  :type 'hook
  :group 'engrave-faces)

(defun engrave-faces-buffer (backend)
  "Export the current buffer with BACKEND and return the created buffer."
  (save-excursion
    ;; Protect against the hook changing the current buffer.
    (save-excursion
      (run-hooks 'engrave-faces-before-hook)
      (run-hooks (intern (concat "engrave-faces-" backend "-before-hook"))))
    ;; Convince font-lock support modes to fontify the entire buffer
    ;; in advance.
    (when (and (boundp 'jit-lock-mode)
               (symbol-value 'jit-lock-mode))
      (jit-lock-fontify-now (point-min) (point-max)))
    (font-lock-ensure)

    ;; It's important that the new buffer inherits default-directory
    ;; from the current buffer.
    (let ((engraved-buf (generate-new-buffer (if (buffer-file-name)
                                                 (concat (file-name-nondirectory (buffer-file-name))
                                                         (plist-get (cdr (assoc backend engrave-faces--backends)) :extension))
                                               (concat "*" backend "*"))))
          (face-transformer (plist-get (cdr (assoc backend engrave-faces--backends)) :face-transformer))
          (completed nil))
      (unwind-protect
          (let (next-change text)
            ;; This loop traverses and reads the source buffer, appending the
            ;; resulting text to the export buffer. This method is fast because:
            ;; 1) it doesn't require examining the text properties char by char
            ;; (engrave-faces-next-face-change is used to move between runs with
            ;; the same face), and 2) it doesn't require frequent buffer
            ;; switches, which are slow because they rebind all buffer-local
            ;; vars.
            (goto-char (point-min))
            (while (not (eobp))
              (setq next-change (engrave-faces-next-face-change (point)))
              (setq text (buffer-substring-no-properties (point) next-change))
              ;; Don't bother writing anything if there's no text (this
              ;; happens in invisible regions).
              (when (> (length text) 0)
                (princ (funcall face-transformer
                                (let ((prop (get-text-property (point) 'face)))
                                  (cond
                                   ((null prop) 'default)
                                   ((and (listp prop)
                                         (eq (car prop) 'quote)) (eval prop))
                                   (t prop)))
                                text)
                       engraved-buf))
              (goto-char next-change)))
        (setq completed t))
      (if (not completed)
          (kill-buffer engraved-buf)
        (with-current-buffer engraved-buf
          (run-hooks 'engrave-faces-after-hook)
          (run-hooks (intern (concat "engrave-faces-" backend "-after-hook"))))
        engraved-buf))))

(defun engrave-faces-merge-attributes (faces &optional attributes)
  "Find the final ATTRIBUTES for text with FACES."
  (setq faces (engrave-faces-explicit-inheritance (if (listp faces) faces (list faces))))
  (mapcan (lambda (attr)
            (list attr (car (engrave-faces-attribute-values faces attr))))
          (or attributes engrave-faces-attributes-of-interest)))

(defun engrave-faces-explicit-inheritance (faces)
  "Expand :inherit for each face in FACES.
I.e. ([facea :inherit faceb] facec) results in (facea faceb facec)"
  (delq nil
        (mapcan
         (lambda (face)
           (if (listp face)
               (let ((inherit (plist-get face :inherit)))
                 (cons (map-delete face :inherit)
                       (engrave-faces-explicit-inheritance inherit)))
             (cons face
                   (let ((inherit (face-attribute face :inherit nil nil)))
                     (when (and inherit (not (eq inherit 'unspecified)))
                       (engrave-faces-explicit-inheritance inherit))))))
         (if (listp faces) faces (list faces)))))

(defun engrave-faces-attribute-values (faces attribute)
  "Fetch all specified instances of ATTRIBUTE for FACES, ignoring inheritence.
To consider inheritence, use `engrave-faces-explicit-inheritance' first."
  (delq nil (delq 'unspecified
                  (mapcar
                   (lambda (face)
                     (or (plist-get (cdr (assoc face engrave-faces-preset-styles)) attribute)
                         (cond
                          ((symbolp face) (face-attribute face attribute nil nil))
                          ((listp face) (plist-get face attribute)))))
                   (delq 'default (if (listp faces) faces (list faces)))))))

(defun engrave-faces-next-face-change (pos &optional limit)
  "Find the next face change from POS up to LIMIT.

This function is lifted from htmlize."
  ;; (engrave-faces-next-change pos 'face limit) would skip over entire
  ;; overlays that specify the `face' property, even when they
  ;; contain smaller text properties that also specify `face'.
  ;; Emacs display engine merges those faces, and so must we.
  (or limit
      (setq limit (point-max)))
  (let ((next-prop (next-single-property-change pos 'face nil limit))
        (overlay-faces (engrave-faces-overlay-faces-at pos)))
    (while (progn
             (setq pos (next-overlay-change pos))
             (and (< pos next-prop)
                  (equal overlay-faces (engrave-faces-overlay-faces-at pos)))))
    (setq pos (min pos next-prop))
    ;; Additionally, we include the entire region that specifies the
    ;; `display' property.
    (when (get-char-property pos 'display)
      (setq pos (next-single-char-property-change pos 'display nil limit)))
    pos))

(defun engrave-faces-overlay-faces-at (pos)
  (delq nil (mapcar (lambda (o) (overlay-get o 'face)) (overlays-at pos))))

;;; Style helpers

(defcustom engrave-faces-preset-styles ; doom-one-light
  '((default                             :short "default"          :slug "D"     :foreground "#383a42")
    (font-lock-keyword-face              :short "keyword"          :slug "k"     :foreground "#e45649")
    (font-lock-doc-face                  :short "doc"              :slug "d"     :foreground "#84888b" :slant italic)
    (font-lock-type-face                 :short "type"             :slug "t"     :foreground "#986801")
    (font-lock-string-face               :short "string"           :slug "s"     :foreground "#50a14f")
    (font-lock-warning-face              :short "warning"          :slug "w"     :foreground "#986801")
    (font-lock-builtin-face              :short "builtin"          :slug "b"     :foreground "#a626a4")
    (font-lock-comment-face              :short "comment"          :slug "ct"    :foreground "#9ca0a4")
    (font-lock-constant-face             :short "constant"         :slug "c"     :foreground "#b751b6")
    (font-lock-preprocessor-face         :short "preprocessor"     :slug "pp"    :foreground "#4078f2" :weight bold)
    (font-lock-negation-char-face        :short "neg-char"         :slug "nc"    :foreground "#4078f2" :weight bold)
    (font-lock-variable-name-face        :short "variable"         :slug "v"     :foreground "#6a1868")
    (font-lock-function-name-face        :short "function"         :slug "f"     :foreground "#a626a4")
    (font-lock-comment-delimiter-face    :short "comment-delim"    :slug "cd"    :foreground "#9ca0a4")
    (font-lock-regexp-grouping-construct :short "regexp"           :slug "rc"    :foreground "#4078f2" :weight bold)
    (font-lock-regexp-grouping-backslash :short "regexp-backslash" :slug "rb"    :foreground "#4078f2" :weight bold)
    (org-block                           :short "org-block"        :slug "ob") ; forcing no background is preferable
    (highlight-numbers-number            :short "number"           :slug "hn"    :foreground "#da8548" :weight bold)
    (highlight-quoted-quote              :short "qquote"           :slug "hq"    :foreground "#4078f2")
    (highlight-quoted-symbol             :short "qsymbol"          :slug "hs"    :foreground "#986801")
    (rainbow-delimiters-depth-1-face     :short "rd1"              :slug "rdi"   :foreground "#4078f2")
    (rainbow-delimiters-depth-2-face     :short "rd2"              :slug "rdii"  :foreground "#a626a4")
    (rainbow-delimiters-depth-3-face     :short "rd3"              :slug "rdiii" :foreground "#50a14f")
    (rainbow-delimiters-depth-4-face     :short "rd4"              :slug "rdiv"  :foreground "#da8548")
    (rainbow-delimiters-depth-5-face     :short "rd5"              :slug "rdv"   :foreground "#b751b6")
    (rainbow-delimiters-depth-6-face     :short "rd6"              :slug "rdvi"  :foreground "#986801")
    (rainbow-delimiters-depth-7-face     :short "rd7"              :slug "rdvii" :foreground "#4db5bd")
    (rainbow-delimiters-depth-8-face     :short "rd8"              :slug "rdiix" :foreground "#80a880")
    (rainbow-delimiters-depth-9-face     :short "rd9"              :slug "rdix"  :foreground "#887070"))
  "Overriding face values.

By setting :foreground, :background, etc. a certain theme can be set for
the faces.  The face attributes here will also be used when calculating
inherited styles.

Faces here will represented more compactly when possible, by using the
:short or :slug parameter to produce a named version styles, wheras other
faces will need to be explicitly styled each time they're used."
  :type '(repeat (repeat (choice symbol string)))
  :group 'engrave-faces)

(defun engrave-faces-check-nondefault (attr value)
  "Return VALUE as long as it is specified, and not the default for ATTR."
  (unless (or (eq value (face-attribute 'default attr nil t))
              (eq value 'unspecified))
    value))

(defun engrave-faces-generate-preset ()
  "Generate `engrave-faces-preset-styles' based on the current theme."
  (mapcar
   (lambda (face-style)
     (apply #'append
            (list (car face-style)
                  :short (plist-get (cdr face-style) :short)
                  :slug (plist-get (cdr face-style) :slug))
            (delq nil
                  (mapcar
                   (lambda (attr)
                     (let ((attr-val (face-attribute (car face-style) attr nil t)))
                       (when (or (engrave-faces-check-nondefault attr attr-val)
                                 (eq (car face-style) 'default))
                         (list attr attr-val))))
                   engrave-faces-attributes-of-interest))))
   engrave-faces-preset-styles))

(provide 'engrave-faces)
;;; engrave-faces.el ends here