branch: externals/engrave-faces
commit 8fe5decb3fa42bcf9c6688575b1a5e3e8beafe8a
Author: TEC <t...@tecosaur.com>
Commit: TEC <t...@tecosaur.com>
Initial commit
---
README.org | 23 +++++
engrave-faces-latex.el | 113 +++++++++++++++++++++++++
engrave-faces.el | 221 +++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 357 insertions(+)
diff --git a/README.org b/README.org
new file mode 100644
index 0000000..d4c1428
--- /dev/null
+++ b/README.org
@@ -0,0 +1,23 @@
+#+title: Engrave Faces
+#+author: tecosaur
+
+There are some great packages for Exporting buffers to particular formats, but
+each one seems to reinvent the core mechanism of processing the font-lock in a
+buffer such that it can be exported to a particular format.
+
+This package aims to produce a versatile generic core which can process a
+fortified buffer and elegantly pass the data to any number of backends which
can
+deal with specific output formats.
+
+This is very much a work in progress, a rough plan can be seen below.
+I fully expect some important items to have been forgotten.
+
+*Font lock processing*
+- [X] Single faces
+- [X] Merge multiple faces
+- [ ] Process overlays
+
+*Included backends*
+- [X] LaTeX
+- [ ] HTML
+- [ ] ANSI
diff --git a/engrave-faces-latex.el b/engrave-faces-latex.el
new file mode 100644
index 0000000..0ffbcc9
--- /dev/null
+++ b/engrave-faces-latex.el
@@ -0,0 +1,113 @@
+;;; engrave-faces-latex.el --- Support for engraving buffers to LaTeX -*-
lexical-binding: t; -*-
+
+;; This file is part of engrave-faces.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;;; Commentary:
+
+;; Support for engraving buffers to LaTeX.
+
+;;; Code:
+
+(require 'engrave-faces)
+
+(defvar engrave-faces-latex-output-style 'preset
+ "TODO")
+
+(defun engrave-faces-latex-gen-preamble ()
+ "TODO"
+ (concat
+ "\\definecolor{EFD}{HTML}{" (substring (plist-get
engrave-faces-preset-default :foreground) 1) "}\n"
+ (mapconcat
+ (lambda (face-style)
+ (engrave-faces-latex-gen-preamble-line (car face-style) (cdr
face-style)))
+ engrave-faces-preset-styles
+ "\n")))
+
+(defun engrave-faces-latex-gen-preamble-line (face style)
+ (let ((short (plist-get style :slug))
+ (fg (plist-get style :foreground))
+ (bg (plist-get style :background))
+ (it (eql (plist-get style :slant) 'italic))
+ (bl (member (plist-get style :weight) '(bold extra-bold))))
+ (concat (when fg (format "\\definecolor{EF%s}{HTML}{%s}\n" short
(substring fg 1)))
+ (when bg (format "\\definecolor{Ef%s}{HTML}{%s}\n" short
(substring bg 1)))
+ "\\newcommand{\\EF" short "}[1]{"
+ (when bg (concat "\\colorbox{Ef" short "}{"))
+ (when fg (concat "\\textcolor{EF" short "}{"))
+ (when bl "\\textbf{") (when it "\\textit{")
+ "#1}"
+ (when bg "}") (when fg "}") (when bl "}") (when it "}")
+ " % " (symbol-name face))))
+
+(defun engrave-faces-latex-face-apply (faces content)
+ "TODO"
+ (let ((attrs (engrave-face-merge-attributes faces)))
+ (let ((fg (plist-get attrs :foreground))
+ (bg (plist-get attrs :background))
+ (it (eql (plist-get attrs :slant) 'italic))
+ (bl (member (plist-get attrs :weight) '(bold extra-bold))))
+ (concat
+ (when bg (concat "\\colorbox[HTML]{" (substring bg 1) "}{"))
+ (when fg (concat "\\textcolor[HTML]{" (substring fg 1) "}{"))
+ (when bl "\\textbf{") (when it "\\textit{")
+ content
+ (when bg "}") (when fg "}") (when bl "}") (when it "}")))))
+
+(defun engrave-faces-latex-face-mapper (faces content)
+ "TODO"
+ (let ((protected-content (replace-regexp-in-string "[\\{}$%&_#]" "\\\\\\&"
content))
+ (style (assoc faces engrave-faces-preset-styles)))
+ (if (string-match-p "\\`[\n[:space:]]+\\'" content)
+ protected-content
+ (if (and style (eq engrave-faces-latex-output-style 'preset))
+ (concat "\\EF" (plist-get (cdr style) :slug) "{" protected-content
"}")
+ (engrave-faces-latex-face-apply faces protected-content)))))
+
+(defvar engrave-faces-latex-char-replacements
+ '(("\\\\" . "\\\\char92{}")
+ ("^" . "\\\\char94{}")
+ ("~" . "\\\\char126{}")))
+
+(defun engrave-faces-latex-post-processing ()
+ (goto-char (point-min))
+ (insert (if (eq engrave-faces-latex-output-style 'preset)
+ "\\color{EFD}"
+ (concat "\\color[HTML]{"
+ (substring (plist-get (assoc 'default
engrave-faces-preset-styles)
+ :foreground) 1)
+ "}")))
+ (dolist (find-sub engrave-faces-latex-char-replacements)
+ (goto-char (point-min))
+ (while (search-forward (car find-sub) nil t)
+ (replace-match (cdr find-sub))))
+ (goto-char (point-min))
+ (while (search-forward "\n}" nil t)
+ (replace-match "}\n")))
+
+(engrave-faces-define-backend "latex" ".tex" #'engrave-faces-latex-face-mapper)
+(add-hook 'engrave-faces-latex-after-hook
#'engrave-faces-latex-post-processing)
+
+(defun engrave-faces-latex-buffer-standalone ()
+ "Export current buffer to a standalone LaTeX buffer."
+ (interactive)
+ (switch-to-buffer (engrave-faces-latex-buffer))
+ (goto-char (point-min))
+ (insert "\\documentclass{article}
+
+\\usepackage{xcolor}
+\\usepackage{fvextra}
+\\usepackage[margin=1.5cm]{geometry}
+\\usepackage{sourcecodepro}
+\\pagestype{empty}\n\n"
+ (engrave-faces-latex-gen-preamble)
+ "
+\\begin{document}
+
+\\begin{Verbatim}[breaklines=true, commandchars=\\\\\\{\\}]\n")
+ (goto-char (point-max))
+ (insert "\\end{Verbatim}
+\\end{document}"))
+
+(provide 'engrave-faces-latex)
+;;; engrave-faces-latex.el ends here
diff --git a/engrave-faces.el b/engrave-faces.el
new file mode 100644
index 0000000..99c317c
--- /dev/null
+++ b/engrave-faces.el
@@ -0,0 +1,221 @@
+;;; engrave-faces.el --- Convert font-lock faces to other formats -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2021 TEC
+
+;; Author: TEC <https://github/tecosaur>
+;; Maintainer: TEC <t...@tecosaur.com>
+;; Created: January 18, 2021
+;; Modified: January 18, 2021
+;; Version: 0.0.1
+;; Keywords: faces
+;; Homepage: https://github.com/tec/engrave-faces
+;; Package-Requires: ((emacs "27.1"))
+
+;;; License:
+
+;; This file is part of org-pandoc-import, which is not part of GNU Emacs.
+;;
+;; org-pandoc-import 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.
+;;
+;; org-pandoc-import 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 org-pandoc-import. 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:
+
+(defvar engrave-faces--backends nil)
+(defmacro engrave-faces-define-backend (name extension face-transformer)
+ `(progn (add-to-list 'engrave-faces--backends
+ (list ,name :face-transformer ,face-transformer
:extension ,extension))
+ (defun ,(intern (concat "engrave-faces-" name "-buffer")) ()
+ (concat "Convert buffer to " ,name " formatting")
+ (engrave-faces-buffer-1 ,name))
+ (defvar ,(intern (concat "engrave-faces-" name "-before-hook")) nil)
+ (defvar ,(intern (concat "engrave-faces-" name "-after-hook")) nil)))
+
+(defun engrave-faces-region-for-paste (beg end)
+ "Convert the region between BEG and END to ANSI."
+ (let ((engraved-buf (save-restriction
+ (narrow-to-region beg end)
+ (engrave-faces-buffer-1))))
+ (unwind-protect
+ (with-current-buffer engraved-buf
+ (buffer-string))
+ (kill-buffer engraved-buf))))
+
+(defvar engrave-faces-attributes-of-interest
+ '(:foreground :background :slant :weight :height)
+ "Attributes which sould be paid attention to.")
+
+(defvar engrave-faces-before-hook nil
+ "Hook run before htmlizing a buffer.
+The hook functions are run in the source buffer (not the resulting HTML
+buffer).")
+
+(defvar engrave-faces-after-hook nil
+ "Hook run after htmlizing a buffer.
+Unlike `engrave-faces-before-hook', these functions are run in the generated
+HTML buffer. You may use them to modify the outlook of the final HTML
+output.")
+
+(defun engrave-faces-buffer-1 (backend)
+ ;; Internal function; don't call it from outside this file. Ansify
+ ;; current buffer, writing the resulting ANSI to a new buffer, and
+ ;; return it.
+ (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 ANSI to ANSIBUF. 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
+ (or (get-text-property (point) 'face)
+ 'default)
+ 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)
+ (apply #'append
+ (mapcar (lambda (attr)
+ (list attr
+ (car
+ (delq nil
+ (delq 'unspecified
+ (mapcar (lambda (face)
+ (face-attribute face attr nil
t))
+ (delq 'default (if (listp faces)
faces (list faces)))))))))
+ engrave-faces-attributes-of-interest)))
+
+(defun engrave-faces-next-face-change (pos &optional limit)
+ ;; (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
+
+(defvar engrave-faces-preset-styles ; doom-one-light
+ '((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)
+ (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"))
+ "TODO")
+
+(defvar engrave-faces-preset-default '(:foreground "#383a42")
+ "TODO")
+
+(defun engrave-faces-check-nondefault (attr value)
+ (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 (engrave-faces-check-nondefault attr attr-val)
+ (list attr attr-val))))
+ engrave-faces-attributes-of-interest))))
+ engrave-faces-preset-styles))
+
+(provide 'engrave-faces)
+;;; engrave-faces.el ends here
