branch: externals/engrave-faces
commit 4a0d16715a8fc7b1d6f88ecc2c6a83ab5eeef2ea
Author: TEC <t...@tecosaur.com>
Commit: TEC <t...@tecosaur.com>
Themes support
---
engrave-faces-html.el | 8 +-
engrave-faces-latex.el | 24 ++--
engrave-faces.el | 294 +++++++++++++++++++++++++++++++++----------------
3 files changed, 217 insertions(+), 109 deletions(-)
diff --git a/engrave-faces-html.el b/engrave-faces-html.el
index 9166e01b0e..72be9d023b 100644
--- a/engrave-faces-html.el
+++ b/engrave-faces-html.el
@@ -25,14 +25,16 @@ When preset, CSS classes are generated for
`engrave-faces-preset-styles'."
:type 'string
:group 'engrave-faces)
-(defun engrave-faces-html-gen-stylesheet (&optional indent)
+(defun engrave-faces-html-gen-stylesheet (&optional theme indent)
"Generate a preamble which provides short commands for the preset styles.
See `engrave-faces-preset-styles' and `engrave-faces-html-output-style'."
(let ((stylesheet
(mapconcat
(lambda (face-style)
(engrave-faces-html--gen-stylesheet-entry (car face-style) (cdr
face-style)))
- engrave-faces-preset-styles
+ (if theme
+ (engrave-faces-get-theme theme)
+ engrave-faces-current-preset-style)
"\n")))
(if indent
(mapconcat (lambda (line)
@@ -125,7 +127,7 @@ See `engrave-faces-preset-styles' and
`engrave-faces-html-output-style'."
(buffer-name)))
"</title>
<style>"
- (let* ((default-sty (cdr (assoc 'default
engrave-faces-preset-styles)))
+ (let* ((default-sty (cdr (assoc 'default
engrave-faces-current-preset-style)))
(default-bg (plist-get default-sty :background))
(default-fg (plist-get default-sty :foreground)))
(if (or default-bg default-fg)
diff --git a/engrave-faces-latex.el b/engrave-faces-latex.el
index f7c867ebc0..48dbbdbec8 100644
--- a/engrave-faces-latex.el
+++ b/engrave-faces-latex.el
@@ -27,18 +27,22 @@ When preset, short commands are generated for
`engrave-faces-preset-styles'."
:type 'string
:group 'engrave-faces)
-(defun engrave-faces-latex-gen-preamble ()
+(defun engrave-faces-latex-gen-preamble (&optional theme)
"Generate a preamble which provides short commands for the preset styles.
See `engrave-faces-preset-styles' and `engrave-faces-latex-output-style'."
- (concat
- (unless (cl-notany (lambda (s) (plist-get (cdr s) :background))
- engrave-faces-preset-styles)
- (format "\\newcommand\\efstrut{%s}\n" engrave-faces-latex-colorbox-strut))
- (mapconcat
- (lambda (face-style)
- (engrave-faces-latex-gen-preamble-line (car face-style) (cdr
face-style)))
- engrave-faces-preset-styles
- "\n")))
+ (let ((preset-style
+ (if theme
+ (engrave-faces-get-theme theme)
+ engrave-faces-current-preset-style)))
+ (concat
+ (unless (cl-notany (lambda (s) (plist-get (cdr s) :background))
+ preset-style)
+ (format "\\newcommand\\efstrut{%s}\n"
engrave-faces-latex-colorbox-strut))
+ (mapconcat
+ (lambda (face-style)
+ (engrave-faces-latex-gen-preamble-line (car face-style) (cdr
face-style)))
+ preset-style
+ "\n"))))
(defun engrave-faces-latex-gen-preamble-line (face style)
"Generate a LaTeX preamble line for STYLE representing FACE."
diff --git a/engrave-faces.el b/engrave-faces.el
index 903d9e4078..a6d3940b89 100644
--- a/engrave-faces.el
+++ b/engrave-faces.el
@@ -79,103 +79,109 @@ If STANDALONE-TRANSFORMER is given it will be used when
directly creating a file
and cause a -standalone version of the buffer transforming function to be
created."
`(progn (add-to-list 'engrave-faces--backends
(list ,backend :face-transformer ,face-transformer
:extension ,extension))
- (defun ,(intern (concat "engrave-faces-" backend "-buffer"))
(&optional switch-to-result)
+ (defun ,(intern (concat "engrave-faces-" backend "-buffer"))
(&optional theme switch-to-result)
,(concat "Convert buffer to " backend " formatting.")
(interactive '(t))
- (let ((buf (engrave-faces-buffer ,backend)))
+ (let ((buf (engrave-faces-buffer ,backend theme)))
(when switch-to-result
(switch-to-buffer buf)
,(when view-setup `(funcall ,view-setup)))
buf))
,(when standalone-transformer
- `(defun ,(intern (concat "engrave-faces-" backend
"-buffer-standalone")) (&optional switch-to-result)
+ `(defun ,(intern (concat "engrave-faces-" backend
"-buffer-standalone")) (&optional theme switch-to-result)
(interactive '(t))
,(concat "Export the current buffer to a standalone " backend
" buffer.")
- (let ((buf (engrave-faces-buffer ,backend)))
+ (let ((buf (engrave-faces-buffer ,backend theme)))
(with-current-buffer buf
(funcall ,standalone-transformer))
(when switch-to-result
(switch-to-buffer buf)
,(when view-setup `(funcall ,view-setup)))
buf)))
- (defun ,(intern (concat "engrave-faces-" backend "-file")) (file
&optional out-file open-result)
+ (defun ,(intern (concat "engrave-faces-" backend "-file")) (file
&optional out-file theme open-result)
,(concat "Convert file to " backend " formatting.")
(interactive (list buffer-file-name nil t))
(unless out-file
(setq out-file (concat file ,extension)))
- (engrave-faces-file file out-file ,backend ,standalone-transformer)
+ (engrave-faces-file file out-file ,backend theme
,standalone-transformer)
(when open-result (find-file out-file))
out-file)
(defvar ,(intern (concat "engrave-faces-" backend "-before-hook"))
nil)
(defvar ,(intern (concat "engrave-faces-" backend "-after-hook"))
nil)))
-(defun engrave-faces-file (in-file out-file backend &optional postprocessor)
+(defun engrave-faces-file (in-file out-file backend &optional theme
postprocessor)
"Using BACKEND, engrave IN-FILE and save it as FILE.EXTENSION.
If a POSTPROCESSOR function is provided, it is called before saving."
(with-temp-buffer
(insert-file-contents in-file)
(let ((buffer-file-name in-file))
(normal-mode)
- (with-current-buffer (engrave-faces-buffer backend)
+ (with-current-buffer (engrave-faces-buffer backend theme)
(when postprocessor (funcall postprocessor))
(write-region (point-min) (point-max) out-file)
(kill-buffer)))))
-(defun engrave-faces-buffer (backend)
+(defun engrave-faces-buffer (backend &optional theme)
"Export the current buffer with BACKEND and return the created buffer."
- (save-excursion
- ;; Protect against the hook changing the current buffer.
+ (let ((engrave-faces-current-preset-style
+ (if theme
+ (engrave-faces-get-theme theme)
+ engrave-faces-current-preset-style)))
(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))
- (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))))
+ ;; 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))
+ (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."
@@ -214,7 +220,7 @@ To consider inheritence, use
`engrave-faces-explicit-inheritance' first."
(delq nil (delq 'unspecified
(mapcar
(lambda (face)
- (if-let ((style (cdr (assoc face
engrave-faces-preset-styles))))
+ (if-let ((style (cdr (assoc face
engrave-faces-current-preset-style))))
(plist-get style attribute)
(cond
((symbolp face)
@@ -232,8 +238,8 @@ This function is lifted from htmlize."
;; 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)))
+ (unless 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
@@ -252,36 +258,70 @@ This function is lifted from htmlize."
;;; 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"))
+(defcustom engrave-faces-themes
+ '((default .
+ (;; faces.el --- excluding: bold, italic, bold-italic, underline, and
some others
+ (default :short "default" :slug
"D" :foreground "#000000")
+ (shadow :short "shadow" :slug
"sh" :foreground "#7f7f7f")
+ (success :short "success" :slug
"ss" :foreground "#228b22" :weight bold)
+ (warning :short "warning" :slug
"w" :foreground "#ff8e00" :weight bold)
+ (error :short "error" :slug
"e" :foreground "#ff0000" :weight bold)
+ ;; font-lock.el
+ (font-lock-comment-face :short "comment" :slug
"ct" :foreground "#b22222")
+ (font-lock-comment-delimiter-face :short "comment-delim" :slug
"cd" :foreground "#b22222")
+ (font-lock-string-face :short "string" :slug
"s" :foreground "#8b2252")
+ (font-lock-doc-face :short "doc" :slug
"d" :foreground "#8b2252")
+ (font-lock-doc-markup-face :short "doc-markup" :slug
"dm" :foreground "#008b8b")
+ (font-lock-keyword-face :short "keyword" :slug
"k" :foreground "#9370db")
+ (font-lock-builtin-face :short "builtin" :slug
"b" :foreground "#483d8b")
+ (font-lock-function-name-face :short "function" :slug
"f" :foreground "#0000ff")
+ (font-lock-variable-name-face :short "variable" :slug
"v" :foreground "#a0522d")
+ (font-lock-type-face :short "type" :slug
"t" :foreground "#228b22")
+ (font-lock-constant-face :short "constant" :slug
"c" :foreground "#008b8b")
+ (font-lock-warning-face :short "fl-warning" :slug
"W" :foreground "#ff0000" :weight bold)
+ (font-lock-negation-char-face :short "neg-char" :slug
"nc")
+ (font-lock-preprocessor-face :short "preprocessor" :slug
"pp" :foreground "#483d8b")
+ (font-lock-regexp-grouping-construct :short "regexp" :slug
"rc" :weight bold)
+ (font-lock-regexp-grouping-backslash :short "regexp-backslash" :slug
"rb" :weight bold)
+ ;; org-faces.el
+ (org-block :short "org-block" :slug
"ob") ; forcing no background is preferable
+ ;; highlight-numbers.el
+ (highlight-numbers-number :short "number" :slug
"hn" :foreground "#008b8b")
+ ;; highlight-quoted.el
+ (highlight-quoted-quote :short "qquote" :slug
"hq" :foreground "#9370db")
+ (highlight-quoted-symbol :short "qsymbol" :slug
"hs" :foreground "#008b8b")
+ ;; rainbow-delimiters.el
+ (rainbow-delimiters-depth-1-face :short "rd1" :slug
"rdi" :foreground "#707183")
+ (rainbow-delimiters-depth-2-face :short "rd2" :slug
"rdii" :foreground "#7388d6")
+ (rainbow-delimiters-depth-3-face :short "rd3" :slug
"rdiii" :foreground "#909183")
+ (rainbow-delimiters-depth-4-face :short "rd4" :slug
"rdiv" :foreground "#709870")
+ (rainbow-delimiters-depth-5-face :short "rd5" :slug
"rdv" :foreground "#907373")
+ (rainbow-delimiters-depth-6-face :short "rd6" :slug
"rdvi" :foreground "#6276ba")
+ (rainbow-delimiters-depth-7-face :short "rd7" :slug
"rdvii" :foreground "#858580")
+ (rainbow-delimiters-depth-8-face :short "rd8" :slug
"rdiix" :foreground "#80a880")
+ (rainbow-delimiters-depth-9-face :short "rd9" :slug
"rdix" :foreground "#887070"))))
+ "A collection of named style presets.
+
+This takes the form of an alist with theme names as the cars, with
+cdrs in the form of `engrave-faces-current-preset-style'."
+ :type '(alist
+ :key-type (symbol :tag "Theme name")
+ :value-type
+ (repeat
+ (cons (symbol :tag "Face")
+ (plist :key-type (choice
+ (const :tag "Short identifier" :short)
+ (const :tag "Very short identifier" :slug)
+ (symbol :tag "Face attribute")
+ :tag "Property")
+ :value-type (choice :tag "Value" string symbol)
+ :tag "Face specification"))))
+ :group 'engrave-faces)
+
+(define-obsolete-variable-alias 'engrave-faces-preset-styles
'engrave-faces-current-preset-style "0.3")
+
+(defcustom engrave-faces-current-preset-style
+ (alist-get 'default engrave-faces-themes)
"Overriding face values.
By setting :foreground, :background, etc. a certain theme can be set for
@@ -291,7 +331,15 @@ 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)))
+ :type '(repeat
+ (cons (symbol :tag "Face")
+ (plist :key-type (choice
+ (const :tag "Short identifier" :short)
+ (const :tag "Very short identifier" :slug)
+ (symbol :tag "Face attribute")
+ :tag "Property")
+ :value-type (choice :tag "Value" string symbol)
+ :tag "Face specification")))
:group 'engrave-faces)
(defun engrave-faces--check-nondefault (attr value)
@@ -309,7 +357,7 @@ Unconditionally returns nil when FACES is default."
((and (pred listp) (app length 1)) (assoc (car faces)
engrave-faces-preset-styles))))
(defun engrave-faces-generate-preset ()
- "Generate `engrave-faces-preset-styles' based on the current theme."
+ "Generate a preset style based on the current Emacs theme."
(mapcar
(lambda (face-style)
(apply #'append
@@ -327,5 +375,59 @@ Unconditionally returns nil when FACES is default."
engrave-faces-attributes-of-interest))))
engrave-faces-preset-styles))
+(defun engrave-faces-get-theme (theme &optional noput)
+ "Obtain the preset style for THEME.
+Unless NOPUT is non-nil, "
+ (if-let ((theme-preset (alist-get theme engrave-faces-themes)))
+ (setq engrave-faces-current-preset-style theme-preset)
+ (if (or (eq theme (car custom-enabled-themes))
+ (memq theme (custom-available-themes)))
+ (let ((spec
+ (if (eq theme (car custom-enabled-themes))
+ (engrave-faces-generate-preset)
+ (let ((old-theme (car custom-enabled-themes))
+ spec)
+ (load-theme theme t)
+ (setq spec (engrave-faces-generate-preset))
+ (load-theme old-theme t)
+ spec))))
+ (unless noput
+ (push (cons theme spec) engrave-faces-themes))
+ spec)
+ (user-error "Theme `%s' is not found in
`engrave-faces-current-preset-style' or availible Emacs themes." theme))))
+
+(defun engrave-faces-use-theme (&optional theme insert-def)
+ "Select a THEME an apply it as the current engraved preset style.
+When INSERT-DEF is non-nil, or the universal argument has been
+provided, an expression adding THEME to `engrave-faces-themes'
+shall be inserted into the current buffer at point."
+ (interactive (list (intern
+ (completing-read
+ "Theme: "
+ (cl-remove-duplicates
+ (append
+ (mapcar
+ (lambda (theme)
+ (propertize (symbol-name theme) 'face '(italic
font-lock-doc-face)))
+ (custom-available-themes))
+ (list (propertize (symbol-name (car
custom-enabled-themes))
+ 'face '(bold
font-lock-comment-face)))
+ (mapcar #'car engrave-faces-themes)))))
+ (when current-prefix-arg t)))
+ (unless theme
+ (setq theme (car custom-enabled-themes)))
+ (let ((spec (engrave-faces-get-theme theme)))
+ (if insert-def
+ (engrave-faces--insert-theme-def theme spec)
+ (setq engrave-faces-current-preset-style spec))))
+
+(defun engrave-faces--insert-theme-def (name &optional spec)
+ "Insert a definition for the theme NAME with a certain SPEC into the buffer."
+ (insert (pp
+ `(add-to-list
+ 'engrave-faces-themes
+ ',(cons name (or spec
+ (engrave-faces-get-theme name)))))))
+
(provide 'engrave-faces)
;;; engrave-faces.el ends here
