diff options
Diffstat (limited to 'scripts/theme-studio/build-theme.el')
| -rw-r--r-- | scripts/theme-studio/build-theme.el | 218 |
1 files changed, 134 insertions, 84 deletions
diff --git a/scripts/theme-studio/build-theme.el b/scripts/theme-studio/build-theme.el index c869dea18..4432ef57c 100644 --- a/scripts/theme-studio/build-theme.el +++ b/scripts/theme-studio/build-theme.el @@ -6,13 +6,13 @@ ;; The last link in the theme-studio pipeline: turn a theme.json exported by ;; the tool (see scripts/theme-studio/README.md and -;; docs/design/theme-studio-package-faces-spec.org) into a single, +;; docs/specs/theme-studio-package-faces-spec-doing.org) into a single, ;; self-contained, loadable Emacs deftheme written to themes/<name>-theme.el. ;; ;; Four tiers come out of the JSON: -;; - default -- background from assignments.bg, foreground from .p -;; - syntax -- assignments.<cat> -> font-lock / tree-sitter faces, with -;; the bold / italic category sets applied +;; - default -- background from syntax.bg, foreground from syntax.p +;; - syntax -- syntax.<cat> -> font-lock / tree-sitter faces, with full +;; face attrs where Emacs supports them ;; - ui -- the ui keys are already real face names; fg/bg passthrough ;; - packages -- per-package face specs with :inherit / :height / weight / ;; slant @@ -27,10 +27,10 @@ ;; emacs --batch -l build-theme.el \ ;; --eval '(build-theme/convert-file "dupre-revised.json" "themes")' ;; -;; The output is a flat generated deftheme, not the hand-authored -;; palette/faces/theme trio that the original dupre theme ships -- a theme.json -;; carries resolved per-face hex, not dupre's semantic-mapping layer, so a flat -;; deftheme is the faithful output and never clobbers the curated dupre files. +;; The output is a flat generated deftheme: a theme.json carries resolved +;; per-face hex, so the converter emits one custom-theme-set-faces with a +;; literal value per face. Giving generated themes a palette + assignments +;; structure is tracked in its own spec. ;;; Code: @@ -71,30 +71,6 @@ independently is not possible without clobbering types.") "Non-nil when S is a \"#rrggbb\" hex color string." (and (stringp s) (string-match-p "\\`#[0-9a-fA-F]\\{6\\}\\'" s))) -(defun build-theme/--attrs (inherit fg bg bold italic underline strike height) - "Build a face-attribute plist from the given fields, in canonical order. -INHERIT is a face symbol or nil. FG and BG are hex strings or nil. BOLD, -ITALIC, UNDERLINE, and STRIKE are booleans. HEIGHT is a float multiplier; 1.0 -(or nil) is omitted as the default. Only set attributes are written, so a -fully-nil face yields an empty plist." - (let (plist) - (when (and height (numberp height) (/= height 1.0)) - (setq plist (list :height height))) - (when strike (setq plist (append (list :strike-through t) plist))) - (when underline (setq plist (append (list :underline t) plist))) - (when italic (setq plist (append (list :slant 'italic) plist))) - (when bold (setq plist (append (list :weight 'bold) plist))) - (when bg (setq plist (append (list :background bg) plist))) - (when fg (setq plist (append (list :foreground fg) plist))) - (when inherit (setq plist (append (list :inherit inherit) plist))) - plist)) - -(defun build-theme/--face-spec (face attrs) - "Wrap FACE and its ATTRS plist as a `custom-theme-set-faces' spec. -Return nil when ATTRS is empty, so cleared faces emit nothing." - (when attrs - (list face (list (list t attrs))))) - (defun build-theme/--obj-get (obj key) "Value of KEY in alist OBJ, or nil." (cdr (assq key obj))) @@ -106,81 +82,153 @@ Return nil when ATTRS is empty, so cleared faces emit nothing." ((stringp value) (intern value)) (t nil))) +(defun build-theme/--box (box) + "Convert a box spec alist (style/color/width) to an Emacs `:box' value, or nil. +STYLE is \"line\", \"released\", or \"pressed\"; WIDTH defaults to 1; COLOR (a hex +string) applies to the line style and falls through to the face foreground when +unset." + (when box + (let ((style (build-theme/--obj-get box 'style)) + (color (build-theme/--obj-get box 'color)) + (width (or (build-theme/--obj-get box 'width) 1))) + (cond ((equal style "released") (append (list :line-width width :style 'released-button) + (when color (list :color color)))) + ((equal style "pressed") (append (list :line-width width :style 'pressed-button) + (when color (list :color color)))) + ((equal style "line") (if color (list :line-width width :color color) + (list :line-width width))) + (t nil))))) + +(defun build-theme/--weight (obj) + "Weight symbol for OBJ: explicit `weight' string, else the legacy `bold' flag." + (let ((w (build-theme/--obj-get obj 'weight))) + (cond ((and (stringp w) (> (length w) 0)) (intern w)) + ((build-theme/--obj-get obj 'bold) 'bold)))) + +(defun build-theme/--slant (obj) + "Slant symbol for OBJ: explicit `slant' string, else the legacy `italic' flag." + (let ((s (build-theme/--obj-get obj 'slant))) + (cond ((and (stringp s) (> (length s) 0)) (intern s)) + ((build-theme/--obj-get obj 'italic) 'italic)))) + +(defun build-theme/--line-attr (val) + "Coerce an overline/strike-through VAL to an Emacs attribute value. +nil and t pass through; a {color: C} alist becomes C, or t when COLOR is unset. +Tolerates the legacy boolean form." + (cond ((null val) nil) + ((eq val t) t) + ((consp val) (or (build-theme/--obj-get val 'color) t)) + (t t))) + +(defun build-theme/--underline (obj) + "Underline attribute value for OBJ. +nil when unset. t is a plain line in the face color. A color or wave style +yields a (:color C :style S) plist. Tolerates the legacy boolean form." + (let ((u (build-theme/--obj-get obj 'underline))) + (cond ((null u) nil) + ((eq u t) t) + ((consp u) + (let* ((color (build-theme/--obj-get u 'color)) + (style (build-theme/--obj-get u 'style)) + (wave (and (stringp style) (not (equal style "line")) (intern style)))) + (cond ((and color wave) (list :color color :style wave)) + (color (list :color color)) + (wave (list :style wave)) + (t t)))) + (t t)))) + +(defun build-theme/--attrs (obj) + "Build a face-attribute plist from face-spec alist OBJ, in canonical order. +Reads the full attribute model -- inherit, family, fg/bg, distant-foreground, +weight, slant, height, underline, overline, strike-through, box, inverse-video, +extend -- and tolerates the older boolean bold/italic/underline/strike fields. +Only attributes that are set appear, so a blank face yields nil." + (let* ((height (build-theme/--obj-get obj 'height)) + (family (build-theme/--obj-get obj 'family)) + (pairs + (list + (cons :inherit (build-theme/--inherit-symbol (build-theme/--obj-get obj 'inherit))) + (cons :family (and (stringp family) (> (length family) 0) family)) + (cons :foreground (build-theme/--obj-get obj 'fg)) + (cons :background (build-theme/--obj-get obj 'bg)) + (cons :distant-foreground (build-theme/--obj-get obj 'distant-fg)) + (cons :weight (build-theme/--weight obj)) + (cons :slant (build-theme/--slant obj)) + (cons :height (and (numberp height) (/= height 1.0) height)) + (cons :underline (build-theme/--underline obj)) + (cons :overline (build-theme/--line-attr (build-theme/--obj-get obj 'overline))) + (cons :strike-through (build-theme/--line-attr (build-theme/--obj-get obj 'strike))) + (cons :box (build-theme/--box (build-theme/--obj-get obj 'box))) + (cons :inverse-video (and (build-theme/--obj-get obj 'inverse) t)) + (cons :extend (and (build-theme/--obj-get obj 'extend) t)))) + (plist nil)) + (dolist (pair pairs) + (when (cdr pair) + (setq plist (nconc plist (list (car pair) (cdr pair)))))) + plist)) + +(defun build-theme/--face-spec (face attrs) + "Wrap FACE and its ATTRS plist as a `custom-theme-set-faces' spec. +Return nil when ATTRS is empty, so cleared faces emit nothing." + (when attrs + (list face (list (list t attrs))))) + ;;; --------------------------------------------------------------------------- ;;; Tiers -(defun build-theme/--default-spec (assignments) - "Build the `default' face spec from ASSIGNMENTS bg / p." - (let ((bg (build-theme/--obj-get assignments 'bg)) - (fg (build-theme/--obj-get assignments 'p))) - (build-theme/--face-spec 'default (build-theme/--attrs nil fg bg nil nil nil nil nil)))) +(defun build-theme/--default-spec (syntax) + "Build the `default' face spec from SYNTAX bg / p entries." + (let ((bg (build-theme/--obj-get (build-theme/--obj-get syntax 'bg) 'fg)) + (fg (build-theme/--obj-get (build-theme/--obj-get syntax 'p) 'fg))) + (build-theme/--face-spec 'default (build-theme/--attrs (list (cons 'fg fg) (cons 'bg bg)))))) -(defun build-theme/--syntax-face-specs (assignments bold italic) - "Build syntax-tier face specs from ASSIGNMENTS plus the BOLD and ITALIC sets. -BOLD and ITALIC are lists of category-key symbols. Each category fans out to -the font-lock faces in `build-theme/--syntax-face-map'." +(defun build-theme/--syntax-face-specs (syntax) + "Build syntax-tier face specs from SYNTAX. +Each category fans out to the font-lock faces in +`build-theme/--syntax-face-map'." (let (specs) (dolist (pair build-theme/--syntax-face-map) (let* ((cat (car pair)) (faces (cdr pair)) - (hex (build-theme/--obj-get assignments cat))) - (when hex - (let ((attrs (build-theme/--attrs nil hex nil - (memq cat bold) (memq cat italic) nil nil nil))) + (obj (build-theme/--obj-get syntax cat))) + (when obj + (let ((attrs (build-theme/--attrs obj))) (dolist (face faces) (when-let ((spec (build-theme/--face-spec face attrs))) (push spec specs))))))) (nreverse specs))) -(defun build-theme/--ui-face-specs (ui) - "Build UI-tier face specs from the UI alist (face -> {fg,bg,bold,italic})." +(defun build-theme/--specs-from-entries (entries) + "Build face specs from ENTRIES, an alist of (face . attribute-alist). +Empty-attr entries emit nothing (cleared faces drop out)." (let (specs) - (dolist (entry ui) - (let* ((face (car entry)) - (obj (cdr entry)) - (attrs (build-theme/--attrs nil - (build-theme/--obj-get obj 'fg) - (build-theme/--obj-get obj 'bg) - (build-theme/--obj-get obj 'bold) - (build-theme/--obj-get obj 'italic) - (build-theme/--obj-get obj 'underline) - (build-theme/--obj-get obj 'strike) - nil))) - (when-let ((spec (build-theme/--face-spec face attrs))) - (push spec specs)))) + (dolist (entry entries) + (when-let ((spec (build-theme/--face-spec + (car entry) + (build-theme/--attrs (cdr entry))))) + (push spec specs))) (nreverse specs))) +(defun build-theme/--ui-face-specs (ui) + "Build UI-tier face specs from the UI alist (face -> attribute alist)." + (build-theme/--specs-from-entries ui)) + (defun build-theme/--package-face-specs (packages) "Build package-tier face specs from the PACKAGES alist (app -> face -> spec)." (let (specs) (dolist (app packages) - (dolist (entry (cdr app)) - (let* ((face (car entry)) - (obj (cdr entry)) - (attrs (build-theme/--attrs - (build-theme/--inherit-symbol (build-theme/--obj-get obj 'inherit)) - (build-theme/--obj-get obj 'fg) - (build-theme/--obj-get obj 'bg) - (build-theme/--obj-get obj 'bold) - (build-theme/--obj-get obj 'italic) - (build-theme/--obj-get obj 'underline) - (build-theme/--obj-get obj 'strike) - (build-theme/--obj-get obj 'height)))) - (when-let ((spec (build-theme/--face-spec face attrs))) - (push spec specs))))) - (nreverse specs))) + (setq specs (nconc specs (build-theme/--specs-from-entries (cdr app))))) + specs)) (defun build-theme/--all-specs (data) "Build the full ordered face-spec list from parsed theme.json DATA." - (let ((assignments (build-theme/--obj-get data 'assignments)) - (bold (mapcar #'intern (build-theme/--obj-get data 'bold))) - (italic (mapcar #'intern (build-theme/--obj-get data 'italic))) + (let ((syntax (build-theme/--obj-get data 'syntax)) (ui (build-theme/--obj-get data 'ui)) (packages (build-theme/--obj-get data 'packages))) (delq nil (append - (list (build-theme/--default-spec assignments)) - (build-theme/--syntax-face-specs assignments bold italic) + (list (build-theme/--default-spec syntax)) + (build-theme/--syntax-face-specs syntax) (build-theme/--ui-face-specs ui) (build-theme/--package-face-specs packages))))) @@ -221,11 +269,13 @@ Signal a `file-missing' error when JSON-FILE does not exist." (defun build-theme/convert-file (json-file &optional out-dir) "Convert JSON-FILE (a theme.json export) into a deftheme file. -Write themes/<name>-theme.el, where <name> is the JSON name field, into -OUT-DIR (default: the themes/ directory of this repo). Return the written -path." +Write themes/<name>-theme.el, where <name> is JSON-FILE's basename, into +OUT-DIR (default: the themes/ directory of this repo). The basename names the +theme so each export lands under its own file (sterling.json becomes +sterling-theme.el), not the name field inside the JSON. +Return the written path." (let* ((data (build-theme/--parse json-file)) - (name (build-theme/--obj-get data 'name)) + (name (file-name-base json-file)) (specs (build-theme/--all-specs data)) (dir (or out-dir (expand-file-name |