diff --git a/tp-builtins-tests.el b/tp-builtins-tests.el index 27562b3..8912b86 100644 --- a/tp-builtins-tests.el +++ b/tp-builtins-tests.el @@ -234,6 +234,51 @@ tp-builtins restores the shipped layer definitions." (should-not (tp-parse-color nil)) (should-error (tp-parse-color 42))) +;;; API-CONC-01: the two palette primaries + +(ert-deftest tp-builtins-test-palette-color-generic-accessor () + "tp-palette-color is the theme-resolving generic accessor." + (tp-builtins-test--with-background-mode 'light + (should (equal (tp-palette-color 'info :fg) "#0969da")) + (should (equal (tp-palette-color 'info :fg) + (tp-palette-fg-color 'info))) + (should (equal (tp-palette-color 'info :bg) + (tp-palette-bg-color 'info))) + (should (equal (tp-palette-color 'info :border) + (tp-palette-border-color 'info))) + (should-not (tp-palette-color 'no-such-palette :fg)) + ;; heatmap-g0 defines only :fg. + (should-not (tp-palette-color 'heatmap-g0 :bg))) + (tp-builtins-test--with-background-mode 'dark + (should (equal (tp-palette-color 'info :fg) "#58a6ff")))) + +(ert-deftest tp-builtins-test-palette-has-p () + "tp-palette-has-p tests palette registration and per-key presence." + (should (tp-palette-has-p 'info)) + (should (tp-palette-has-p 'info :fg)) + (should (tp-palette-has-p 'info :bg)) + (should (tp-palette-has-p 'info :border)) + (should (tp-palette-has-p 'heatmap-g0 :fg)) + (should-not (tp-palette-has-p 'heatmap-g0 :bg)) + (should-not (tp-palette-has-p 'heatmap-g0 :border)) + (should-not (tp-palette-has-p 'no-such-palette)) + (should-not (tp-palette-has-p 'no-such-palette :fg)) + ;; Unlike the suffix predicates, has-p takes the palette name + ;; itself, not a NAME-fg variant symbol. + (should-not (tp-palette-has-p 'info-fg)) + (should (tp-palette-fg-p 'info-fg))) + +;;; DOC-STR-02: tp-suffix-symbol privatized behind an obsolete alias + +(ert-deftest tp-builtins-test-suffix-symbol-obsolete-alias () + "tp-suffix-symbol keeps working as an obsolete compatibility alias." + (should (eq (tp--suffix-symbol 'info "-fg") 'info-fg)) + (should (eq (with-suppressed-warnings ((obsolete tp-suffix-symbol)) + (tp-suffix-symbol 'info "-fg")) + 'info-fg)) + (should (eq (car (get 'tp-suffix-symbol 'byte-obsolete-info)) + 'tp--suffix-symbol))) + ;;; API-NAME-02: prefix-conforming tp-define-palette alias (ert-deftest tp-builtins-test-define-palette-alias () diff --git a/tp-builtins.el b/tp-builtins.el index 1976cdf..c89dcf7 100644 --- a/tp-builtins.el +++ b/tp-builtins.el @@ -90,11 +90,25 @@ its window." `(face (,@(when border-color (list :box (list :color border-color)))))) (_ (error "Invalid palette: %S" palette))))) -(defun tp-suffix-symbol (symbol string) +(defun tp--suffix-symbol (symbol string) + "Intern the symbol named by SYMBOL's name with STRING appended. +For example (tp--suffix-symbol \\='info \"-fg\") returns `info-fg'. +A generic helper with no tp semantics of its own, used by +`tp-palette-show' to build the suffixed palette variant names." (intern (concat (symbol-name symbol) string))) +(define-obsolete-function-alias 'tp-suffix-symbol + 'tp--suffix-symbol "0.3.0") + ;;;###autoload (defun tp-palette-show () + "Display a gallery of every palette registered in `tp-palette-alist'. +Shows the read-only buffer *tp-palette-gallery* listing, for each +palette NAME, the symbols the `tp-palette' layer accepts: NAME itself +\(foreground, background and border together) plus the NAME-fg, +NAME-bg, NAME-fbg and NAME-border variants, each label rendered in +the colors it selects for the current theme. Press \\`q' to quit +the gallery window." (interactive) (let ((alist (seq-reverse tp-palette-alist))) (tp-switch-to-buffer "*tp-palette-gallery*" @@ -109,19 +123,19 @@ its window." " " (tp-set (concat name "-fg") 'tp-palette - (tp-suffix-symbol symbol "-fg")) + (tp--suffix-symbol symbol "-fg")) " " (tp-set (concat name "-bg") 'tp-palette - (tp-suffix-symbol symbol "-bg")) + (tp--suffix-symbol symbol "-bg")) " " (tp-set (concat name "-fbg") 'tp-palette - (tp-suffix-symbol symbol "-fbg")) + (tp--suffix-symbol symbol "-fbg")) " " (tp-set (concat name "-border") 'tp-palette - (tp-suffix-symbol symbol "-border"))))) + (tp--suffix-symbol symbol "-border"))))) alist "\n"))))) (define-tp tp-fg (color) diff --git a/tp-palette.el b/tp-palette.el index e7fd489..e30412d 100644 --- a/tp-palette.el +++ b/tp-palette.el @@ -254,9 +254,11 @@ documentation of NAME and PLIST.") ;;; Utilities (defun tp-theme-dark-p () + "Return non-nil when the current frame's background mode is dark." (eq (frame-parameter nil 'background-mode) 'dark)) (defun tp-theme-light-p () + "Return non-nil when the current frame's background mode is light." (eq (frame-parameter nil 'background-mode) 'light)) (defun tp-parse-color (color) @@ -293,11 +295,49 @@ back to the light color." "Get color value for KEY from the palette named SYMBOL. SYMBOL is looked up in `tp-palette-alist'. KEY should be one of :fg, :bg, or :border. Return nil if SYMBOL names no registered -palette or its definition doesn't contain KEY." +palette or its definition doesn't contain KEY. +The public entry point delegating here is `tp-palette-color'." (let ((plist (alist-get symbol tp-palette-alist))) (when (tp-palette--plistp plist) (tp-parse-color (plist-get plist key))))) +(defun tp-palette-color (symbol key) + "Return the KEY color of the palette named SYMBOL, theme-resolved. +SYMBOL is looked up in `tp-palette-alist'; KEY is one of :fg, :bg or +:border. The stored color spec is resolved for the current theme by +`tp-parse-color', so a (LIGHT . DARK) cons yields the side matching +the frame's background mode. Returns nil when SYMBOL names no +registered palette, its definition has no KEY entry, or the entry +resolves to no color for the current theme. + +This is the generic palette accessor; `tp-palette-fg-color', +`tp-palette-bg-color' and `tp-palette-border-color' are per-key +conveniences equivalent to calling it with a fixed KEY. See also +`tp-palette-has-p' to test for a palette or key without resolving a +color." + (tp-palette--get-color symbol key)) + +(defun tp-palette-has-p (symbol &optional kind) + "Return non-nil when SYMBOL names a palette that defines KIND. +With nil KIND, test only that SYMBOL names a palette registered in +`tp-palette-alist' (like `tp-palette-p'). Otherwise KIND is one of +:fg, :bg or :border, and the palette's definition must contain that +key. A defined key may still resolve to no color for the current +theme (for example a (LIGHT . nil) cons in dark mode); use +`tp-palette-color' when the resolved color itself matters. + +Note that the suffix predicates `tp-palette-fg-p', `tp-palette-bg-p', +`tp-palette-fbg-p' and `tp-palette-border-p' answer a different +question: whether SYMBOL is a suffixed variant name like `info-fg' +naming a registered palette (the `tp-palette' layer's convention). +This predicate takes the palette name itself." + (let ((entry (assoc symbol tp-palette-alist))) + (cond ((null entry) nil) + ((null kind) t) + (t (and (tp-palette--plistp (cdr entry)) + (plist-member (cdr entry) kind) + t))))) + (defun tp-palette-fg-color (symbol) "Get the foreground color from palette SYMBOL. SYMBOL should be a symbol bound to a palette plist with a :fg key. @@ -317,33 +357,52 @@ Returns nil if SYMBOL is unbound or doesn't contain :border." (tp-palette--get-color symbol :border)) (defun tp-palette-p (symbol) + "Return non-nil when SYMBOL names a registered palette. +The value is SYMBOL's entry in `tp-palette-alist'. See also the +generalized `tp-palette-has-p'." (assoc symbol tp-palette-alist)) (defun tp-palette-fg-p (symbol) + "Return non-nil when SYMBOL is a NAME-fg variant of a palette NAME. +Tests the suffixed naming convention of the `tp-palette' layer, not +the palette contents; see `tp-palette-has-p' for the latter." (save-match-data (let ((str (symbol-name symbol))) (and (string-match "\\(.+\\)-fg$" str) (tp-palette-p (intern (match-string 1 str))))))) (defun tp-palette-bg-p (symbol) + "Return non-nil when SYMBOL is a NAME-bg variant of a palette NAME. +Tests the suffixed naming convention of the `tp-palette' layer, not +the palette contents; see `tp-palette-has-p' for the latter." (save-match-data (let ((str (symbol-name symbol))) (and (string-match "\\(.+\\)-bg$" str) (tp-palette-p (intern (match-string 1 str))))))) (defun tp-palette-fbg-p (symbol) + "Return non-nil when SYMBOL is a NAME-fbg variant of a palette NAME. +Tests the suffixed naming convention of the `tp-palette' layer (fg +plus bg), not the palette contents." (save-match-data (let ((str (symbol-name symbol))) (and (string-match "\\(.+\\)-fbg$" str) (tp-palette-p (intern (match-string 1 str))))))) (defun tp-palette-border-p (symbol) + "Return non-nil when SYMBOL is a NAME-border variant of a palette NAME. +Tests the suffixed naming convention of the `tp-palette' layer, not +the palette contents; see `tp-palette-has-p' for the latter." (save-match-data (let ((str (symbol-name symbol))) (and (string-match "\\(.+\\)-border$" str) (tp-palette-p (intern (match-string 1 str))))))) (defun tp-palette-pure (symbol) + "Return the palette name behind SYMBOL, stripping variant suffixes. +SYMBOL may be a registered palette name or one of its -fg/-bg/-fbg/ +-border variants (see the `tp-palette' layer); signal an error for +anything else." (pcase symbol ((pred tp-palette-p) symbol) ((pred tp-palette-fg-p)