path: root/tests/test-build-theme.el

;;; test-build-theme.el --- Tests for the theme.json -> dupre-*.el converter -*- lexical-binding: t -*-

;;; Commentary:

;; ERT tests for scripts/theme-studio/build-theme.el, the converter that
;; turns a theme.json exported by the theme-studio into a loadable Emacs
;; deftheme file.  This is the correctness-sensitive end of the pipeline, so
;; it is covered Normal / Boundary / Error per category.

;;; Code:

(require 'ert)
(require 'json)

;; The converter lives under scripts/, not on the normal load-path.  Add it at
;; compile time too (the validate hook byte-compiles this file in isolation and
;; only -L's the project, modules, tests, and themes dirs).
(eval-and-compile
  (add-to-list 'load-path
               (expand-file-name
                "../scripts/theme-studio"
                (file-name-directory
                 (or load-file-name
                     (bound-and-true-p byte-compile-current-file)
                     buffer-file-name
                     default-directory)))))

(require 'build-theme)

;;; ---------------------------------------------------------------------------
;;; Fixtures

(defconst test-build-theme--fixture-json
  "{
 \"name\": \"dupre-fixture\",
 \"palette\": [[\"#000000\",\"ground\"],[\"#7a9abe\",\"blue\"],[\"#84b068\",\"green\"]],
 \"assignments\": {
  \"bg\":\"#000000\", \"p\":\"#cdced1\",
  \"kw\":\"#7a9abe\", \"str\":\"#84b068\", \"cm\":\"#838d97\", \"dec\":\"#e8bd30\"
 },
 \"bold\": [\"kw\"],
 \"italic\": [\"cm\"],
 \"ui\": {
  \"region\": {\"fg\":null, \"bg\":\"#264364\"},
  \"mode-line\": {\"fg\":\"#cdced1\", \"bg\":\"#2f343a\"}
 },
 \"packages\": {
  \"org-mode\": {
   \"org-level-1\": {\"fg\":\"#67809c\",\"bg\":null,\"bold\":true,\"italic\":false,\"inherit\":null,\"source\":\"default\"},
   \"org-level-2\": {\"fg\":\"#e8bd30\",\"bg\":null,\"bold\":false,\"italic\":false,\"inherit\":\"org-level-1\",\"height\":1.2,\"source\":\"user\"},
   \"org-tag\": {\"fg\":null,\"bg\":null,\"bold\":false,\"italic\":false,\"inherit\":null,\"source\":\"cleared\"}
  }
 }
}"
  "A self-contained theme.json exercising every tier: default, syntax (bold +
italic + the unmappable dec key), UI, and packages (a plain face, an
inherit+height face, and a cleared face).  Owned by the test so it can't drift
the way Craig's downloaded exports under scripts/theme-studio/ can.")

(defun test-build-theme--write-fixture (dir)
  "Write the fixture JSON into DIR and return its path."
  (let ((path (expand-file-name "dupre-fixture.json" dir)))
    (with-temp-file path (insert test-build-theme--fixture-json))
    path))

(defmacro test-build-theme--with-sandbox (var &rest body)
  "Bind VAR to a fresh temp directory, run BODY, then delete it."
  (declare (indent 1))
  `(let ((,var (make-temp-file "build-theme-test-" t)))
     (unwind-protect (progn ,@body)
       (delete-directory ,var t))))

;; --- WCAG contrast helpers (mirror of the dupre-theme test helpers) ---

(defun test-build-theme--channel-luminance (c)
  "Linearize an 8-bit channel value C (0-255) per the WCAG formula."
  (let ((x (/ c 255.0)))
    (if (<= x 0.03928) (/ x 12.92) (expt (/ (+ x 0.055) 1.055) 2.4))))

(defun test-build-theme--relative-luminance (hex)
  "WCAG relative luminance of HEX color \"#rrggbb\"."
  (+ (* 0.2126 (test-build-theme--channel-luminance (string-to-number (substring hex 1 3) 16)))
     (* 0.7152 (test-build-theme--channel-luminance (string-to-number (substring hex 3 5) 16)))
     (* 0.0722 (test-build-theme--channel-luminance (string-to-number (substring hex 5 7) 16)))))

(defun test-build-theme--contrast (fg bg)
  "WCAG contrast ratio between hex colors FG and BG."
  (let ((l1 (test-build-theme--relative-luminance fg))
        (l2 (test-build-theme--relative-luminance bg)))
    (/ (+ (max l1 l2) 0.05) (+ (min l1 l2) 0.05))))

;;; ---------------------------------------------------------------------------
;;; build-theme/--attrs (the core attribute builder)

(ert-deftest test-build-theme-attrs-fg-and-bold ()
  "Normal: a foreground plus bold yields :foreground and :weight bold."
  (should (equal (build-theme/--attrs nil "#67809c" nil t nil nil nil nil)
                 '(:foreground "#67809c" :weight bold))))

(ert-deftest test-build-theme-attrs-full-ordering ()
  "Normal: every attribute present, in canonical order."
  (should (equal (build-theme/--attrs 'org-level-1 "#e8bd30" "#1a1714" t t t t 1.3)
                 '(:inherit org-level-1 :foreground "#e8bd30" :background "#1a1714"
                            :weight bold :slant italic :underline t :strike-through t :height 1.3))))

(ert-deftest test-build-theme-attrs-underline-and-strike ()
  "Normal: underline and strike yield :underline t and :strike-through t."
  (should (equal (build-theme/--attrs nil "#67809c" nil nil nil t t nil)
                 '(:foreground "#67809c" :underline t :strike-through t)))
  ;; either alone
  (should (equal (build-theme/--attrs nil nil nil nil nil t nil nil)
                 '(:underline t)))
  (should (equal (build-theme/--attrs nil nil nil nil nil nil t nil)
                 '(:strike-through t))))

(ert-deftest test-build-theme-attrs-empty-is-nil ()
  "Boundary: a fully-cleared face (all nil) yields an empty plist."
  (should (equal (build-theme/--attrs nil nil nil nil nil nil nil nil) '())))

(ert-deftest test-build-theme-attrs-bold-false-omits-weight ()
  "Boundary: bold false produces no :weight key (only overrides are written)."
  (should (equal (build-theme/--attrs nil "#cdced1" nil nil nil nil nil nil)
                 '(:foreground "#cdced1"))))

(ert-deftest test-build-theme-attrs-height-one-omitted ()
  "Boundary: a height of exactly 1.0 is omitted (the default multiplier)."
  (should (equal (build-theme/--attrs nil "#cdced1" nil nil nil nil nil 1.0)
                 '(:foreground "#cdced1")))
  (should (equal (build-theme/--attrs nil "#cdced1" nil nil nil nil nil 1)
                 '(:foreground "#cdced1"))))

;;; ---------------------------------------------------------------------------
;;; build-theme/--face-spec (skips empty faces)

(ert-deftest test-build-theme-face-spec-normal ()
  "Normal: a face with attrs becomes a custom-theme-set-faces spec."
  (should (equal (build-theme/--face-spec 'font-lock-string-face '(:foreground "#84b068"))
                 '(font-lock-string-face ((t (:foreground "#84b068")))))))

(ert-deftest test-build-theme-face-spec-empty-skipped ()
  "Boundary: a face with no attributes (cleared) yields nil, not an empty spec."
  (should (null (build-theme/--face-spec 'whatever '()))))

;;; ---------------------------------------------------------------------------
;;; Syntax tier

(ert-deftest test-build-theme-syntax-keyword-bold ()
  "Normal: kw maps to font-lock-keyword-face and picks up the bold set."
  (let* ((assignments '((kw . "#7a9abe") (str . "#84b068")))
         (specs (build-theme/--syntax-face-specs assignments '(kw) '())))
    (should (member '(font-lock-keyword-face ((t (:foreground "#7a9abe" :weight bold))))
                    specs))
    (should (member '(font-lock-string-face ((t (:foreground "#84b068"))))
                    specs))))

(ert-deftest test-build-theme-syntax-one-to-many ()
  "Normal: punc fans out to every punctuation/bracket/delimiter face."
  (let ((specs (build-theme/--syntax-face-specs '((punc . "#a9b2bb")) '() '())))
    (dolist (face '(font-lock-punctuation-face font-lock-bracket-face
                    font-lock-delimiter-face font-lock-misc-punctuation-face))
      (should (member `(,face ((t (:foreground "#a9b2bb")))) specs)))))

(ert-deftest test-build-theme-syntax-decorator-omitted ()
  "Boundary: dec has no independent Emacs face, so it maps to nothing.
Emacs renders decorators with font-lock-type-face, which ty already owns;
mapping dec would clobber the type color."
  (let ((specs (build-theme/--syntax-face-specs '((dec . "#e8bd30")) '() '())))
    (should (null specs))))

(ert-deftest test-build-theme-syntax-comment-italic ()
  "Normal: cm in the italic set yields :slant italic on the comment face."
  (let ((specs (build-theme/--syntax-face-specs '((cm . "#a9b2bb")) '() '(cm))))
    (should (member '(font-lock-comment-face ((t (:foreground "#a9b2bb" :slant italic))))
                    specs))))

;;; ---------------------------------------------------------------------------
;;; Default face

(ert-deftest test-build-theme-default-face ()
  "Normal: default takes background from bg and foreground from p."
  (should (equal (build-theme/--default-spec '((bg . "#000000") (p . "#cdced1")))
                 '(default ((t (:foreground "#cdced1" :background "#000000")))))))

;;; ---------------------------------------------------------------------------
;;; UI tier

(ert-deftest test-build-theme-ui-passthrough ()
  "Normal: a ui face passes fg/bg straight through."
  (let ((specs (build-theme/--ui-face-specs
                '((region . ((fg . nil) (bg . "#264364")))
                  (mode-line . ((fg . "#cdced1") (bg . "#2f343a")))))))
    (should (member '(region ((t (:background "#264364")))) specs))
    (should (member '(mode-line ((t (:foreground "#cdced1" :background "#2f343a")))) specs))))

;;; ---------------------------------------------------------------------------
;;; Package tier

(ert-deftest test-build-theme-package-inherit-and-height ()
  "Normal: a package face writes :inherit plus overrides plus :height."
  (let ((specs (build-theme/--package-face-specs
                '((org-mode . ((org-level-2 . ((fg . "#e8bd30") (bg . nil)
                                               (bold . nil) (italic . nil)
                                               (inherit . "org-level-1") (height . 1.2)
                                               (source . "user")))))))))
    (should (member '(org-level-2 ((t (:inherit org-level-1 :foreground "#e8bd30" :height 1.2))))
                    specs))))

(ert-deftest test-build-theme-package-underline-and-strike ()
  "Normal: a package face writes :underline and :strike-through from the flags."
  (let ((specs (build-theme/--package-face-specs
                '((shr . ((shr-link . ((fg . "#67809c") (bg . nil) (bold . nil) (italic . nil)
                                       (underline . t) (strike . nil) (inherit . nil) (source . "default")))
                          (shr-strike-through . ((fg . "#5e6770") (bg . nil) (bold . nil) (italic . nil)
                                                 (underline . nil) (strike . t) (inherit . nil) (source . "default")))))))))
    (should (member '(shr-link ((t (:foreground "#67809c" :underline t)))) specs))
    (should (member '(shr-strike-through ((t (:foreground "#5e6770" :strike-through t)))) specs))))

(ert-deftest test-build-theme-package-cleared-skipped ()
  "Boundary: a cleared package face (no renderable attrs) is not emitted."
  (let ((specs (build-theme/--package-face-specs
                '((org-mode . ((org-tag . ((fg . nil) (bg . nil) (bold . nil)
                                           (italic . nil) (inherit . nil)
                                           (height . nil) (source . "cleared")))))))))
    (should (null specs))))

;;; ---------------------------------------------------------------------------
;;; Hex validation

(ert-deftest test-build-theme-hex-p ()
  "Normal/Error: only #rrggbb strings validate."
  (should (build-theme/--hex-p "#0d0b0a"))
  (should (build-theme/--hex-p "#FFFFFF"))
  (should-not (build-theme/--hex-p "0d0b0a"))
  (should-not (build-theme/--hex-p "#fff"))
  (should-not (build-theme/--hex-p nil)))

;;; ---------------------------------------------------------------------------
;;; End-to-end: convert a file and load the result

(ert-deftest test-build-theme-convert-file-writes-loadable-theme ()
  "Integration: converting the fixture produces a theme Emacs can load.
Components integrated:
- build-theme/convert-file (entry point, real)
- json parsing of the inline fixture (real)
- custom-theme-set-faces / load-theme (real)
Validates the syntax, default, UI, and package tiers all reach real faces,
including an inherit+height package face."
  (require 'org)
  (test-build-theme--with-sandbox out
    (let* ((in (test-build-theme--write-fixture out))
           (path (build-theme/convert-file in out)))
      (should (file-exists-p path))
      (should (string-suffix-p "dupre-fixture-theme.el" path))
      (let ((custom-theme-load-path (cons out custom-theme-load-path))
            (load-path (cons out load-path)))
        (unwind-protect
            (progn
              (load-theme 'dupre-fixture t)
              ;; default tier
              (should (string= (face-attribute 'default :background nil t) "#000000"))
              (should (string= (face-attribute 'default :foreground nil t) "#cdced1"))
              ;; syntax tier (kw is blue + bold in the fixture)
              (should (string= (face-attribute 'font-lock-keyword-face :foreground nil t) "#7a9abe"))
              (should (eq (face-attribute 'font-lock-keyword-face :weight nil t) 'bold))
              ;; ui tier
              (should (string= (face-attribute 'region :background nil t) "#264364"))
              ;; package tier — plain face and an inherit+height face
              (should (string= (face-attribute 'org-level-1 :foreground nil t) "#67809c"))
              (should (eq (face-attribute 'org-level-2 :inherit nil t) 'org-level-1))
              (should (= (face-attribute 'org-level-2 :height nil t) 1.2)))
          (disable-theme 'dupre-fixture))))))

(ert-deftest test-build-theme-convert-file-old-json-without-packages ()
  "Boundary: a theme.json with no packages key still converts and loads."
  (test-build-theme--with-sandbox out
    (let* ((json "{\"name\":\"noformat\",\"palette\":[[\"#000000\",\"ground\"]],\"assignments\":{\"bg\":\"#000000\",\"p\":\"#ffffff\",\"kw\":\"#67809c\"},\"bold\":[\"kw\"],\"italic\":[],\"ui\":{}}")
           (in (expand-file-name "noformat.json" out)))
      (with-temp-file in (insert json))
      (let ((path (build-theme/convert-file in out)))
        (should (file-exists-p path))
        (let ((custom-theme-load-path (cons out custom-theme-load-path))
              (load-path (cons out load-path)))
          (unwind-protect
              (progn
                (load-theme 'noformat t)
                (should (string= (face-attribute 'default :background nil t) "#000000"))
                (should (string= (face-attribute 'font-lock-keyword-face :foreground nil t) "#67809c")))
            (disable-theme 'noformat)))))))

(ert-deftest test-build-theme-convert-file-missing-input-errors ()
  "Error: a missing input file signals rather than writing garbage."
  (test-build-theme--with-sandbox out
    (should-error (build-theme/convert-file (expand-file-name "does-not-exist.json" out) out))))

(ert-deftest test-build-theme-generated-default-meets-wcag-aa ()
  "Error/Regression: the generated default face stays legible.
A WCAG-AA (>= 4.5:1) assertion on the round-tripped result -- proves the whole
parse -> spec -> file -> face pipeline preserves the designed contrast."
  (test-build-theme--with-sandbox out
    (let ((path (build-theme/convert-file (test-build-theme--write-fixture out) out)))
      (let ((custom-theme-load-path (cons out custom-theme-load-path))
            (load-path (cons out load-path)))
        (unwind-protect
            (progn
              (load-theme 'dupre-fixture t)
              (let ((fg (face-attribute 'default :foreground nil t))
                    (bg (face-attribute 'default :background nil t)))
                (should (>= (test-build-theme--contrast fg bg) 4.5))))
          (disable-theme 'dupre-fixture))))))

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