path: root/scripts/theme-studio/build-theme.el

;;; build-theme.el --- Convert a theme-studio theme.json into a deftheme -*- lexical-binding: t -*-

;; Author: Craig Jennings <c@cjennings.net>

;;; Commentary:

;; The last link in the theme-studio pipeline: turn a theme.json exported by
;; the tool (see scripts/theme-studio/README.md and
;; 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 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
;;
;; Usage (from a shell or a running Emacs):
;;
;;   emacsclient -e '(progn (load ".../build-theme.el")
;;                          (build-theme/convert-file ".../dupre-revised.json"))'
;;
;; or in batch:
;;
;;   emacs --batch -l build-theme.el \
;;     --eval '(build-theme/convert-file "dupre-revised.json" "themes")'
;;
;; 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:

(require 'json)
(require 'subr-x)

(defconst build-theme/--syntax-face-map
  '((kw   . (font-lock-keyword-face))
    (bi   . (font-lock-builtin-face))
    (pp   . (font-lock-preprocessor-face))
    (fnd  . (font-lock-function-name-face))
    (fnc  . (font-lock-function-call-face))
    (ty   . (font-lock-type-face))
    (prop . (font-lock-property-name-face font-lock-property-use-face))
    (con  . (font-lock-constant-face))
    (num  . (font-lock-number-face))
    (str  . (font-lock-string-face))
    (esc  . (font-lock-escape-face))
    (re   . (font-lock-regexp-face))
    (doc  . (font-lock-doc-face))
    (cm   . (font-lock-comment-face))
    (cmd  . (font-lock-comment-delimiter-face))
    (var  . (font-lock-variable-name-face font-lock-variable-use-face))
    (op   . (font-lock-operator-face))
    (punc . (font-lock-punctuation-face font-lock-bracket-face
             font-lock-delimiter-face font-lock-misc-punctuation-face)))
  "Map each theme.json syntax-category key to the font-lock faces it colors.
A category may fan out to several faces (e.g. punc covers bracket and
delimiter too).  The dec (decorator) key is deliberately absent: Emacs has
no dedicated decorator face -- it renders decorators with
`font-lock-type-face', which the ty key already owns -- so coloring dec
independently is not possible without clobbering types.")

;;; ---------------------------------------------------------------------------
;;; Pure helpers

(defun build-theme/--hex-p (s)
  "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/--obj-get (obj key)
  "Value of KEY in alist OBJ, or nil."
  (cdr (assq key obj)))

(defun build-theme/--inherit-symbol (value)
  "Coerce an inherit VALUE (a face-name string, symbol, or nil) to a symbol."
  (cond ((null value) nil)
        ((symbolp value) value)
        ((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 (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 (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))
             (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 -> attribute alist)."
  (let (specs)
    (dolist (entry ui)
      (let* ((face (car entry))
             (obj (cdr entry))
             (attrs (build-theme/--attrs obj)))
        (when-let ((spec (build-theme/--face-spec face attrs)))
          (push spec specs))))
    (nreverse specs)))

(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 obj)))
          (when-let ((spec (build-theme/--face-spec face attrs)))
            (push spec specs)))))
    (nreverse specs)))

(defun build-theme/--all-specs (data)
  "Build the full ordered face-spec list from parsed theme.json DATA."
  (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 syntax))
           (build-theme/--syntax-face-specs syntax)
           (build-theme/--ui-face-specs ui)
           (build-theme/--package-face-specs packages)))))

;;; ---------------------------------------------------------------------------
;;; Rendering

(defun build-theme/--render (name specs)
  "Render a deftheme file body for theme NAME from face SPECS, as a string."
  (concat
   (format ";;; %s-theme.el --- Generated by theme-studio -*- lexical-binding: t -*-\n" name)
   "\n;;; Commentary:\n"
   (format ";; Generated from %s.json by scripts/theme-studio/build-theme.el.\n" name)
   ";; Do not hand-edit; re-run the converter.\n"
   "\n;;; Code:\n\n"
   (format "(deftheme %s\n  \"Generated by theme-studio.\")\n\n" name)
   (format "(custom-theme-set-faces\n '%s\n" name)
   ;; Each spec is quoted: custom-theme-set-faces is a function, so an
   ;; unquoted (face ((t ...))) would be evaluated as a call.  Specs hold
   ;; only literal strings, symbols, and numbers, so a plain quote suffices.
   (mapconcat (lambda (spec) (concat " '" (prin1-to-string spec))) specs "\n")
   ")\n\n"
   (format "(provide-theme '%s)\n" name)
   (format ";;; %s-theme.el ends here\n" name)))

(defun build-theme/--parse (json-file)
  "Parse JSON-FILE into an alist, with null/false as nil and arrays as lists.
Signal a `file-missing' error when JSON-FILE does not exist."
  (unless (file-readable-p json-file)
    (signal 'file-missing (list "Cannot read theme.json" json-file)))
  (with-temp-buffer
    (insert-file-contents json-file)
    (goto-char (point-min))
    (json-parse-buffer :object-type 'alist :array-type 'list
                       :null-object nil :false-object nil)))

;;; ---------------------------------------------------------------------------
;;; Entry point

(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 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 (file-name-base json-file))
         (specs (build-theme/--all-specs data))
         (dir (or out-dir
                  (expand-file-name
                   "../../themes"
                   (file-name-directory (or load-file-name buffer-file-name
                                            default-directory)))))
         (out (expand-file-name (format "%s-theme.el" name) dir)))
    (unless (and (stringp name) (string-match-p "\\`[a-zA-Z][a-zA-Z0-9-]*\\'" name))
      (error "Invalid theme name in %s: %S" json-file name))
    (make-directory dir t)
    (with-temp-file out
      (insert (build-theme/--render name specs)))
    out))

(provide 'build-theme)
;;; build-theme.el ends here