[Emacs-diffs] master bd9e8b3: Add command for cycling between CSS color formats

[Simen Heggestøyl]

branch: master
commit bd9e8b31a1a38a2ffa5c2ff5e805a42ffccc36ec
Author: Simen Heggestøyl <address@hidden>
Commit: Simen Heggestøyl <address@hidden>

    Add command for cycling between CSS color formats
    
    * lisp/textmodes/css-mode.el (css-mode-map): Add keybinding for
    'css-cycle-color-format'.
    (css--rgb-color): Add support for extracting alpha component.
    (css--hex-alpha, css--color-to-4-dpc, css--named-color-to-hex)
    (css--format-rgba-alpha, css--hex-to-rgb)
    (css--rgb-to-named-color-or-hex): New functions.
    (css-cycle-color-format): New command for cycling between color
    formats.
    
    * test/lisp/textmodes/css-mode-tests.el (css-test-color-to-4-dpc):
    (css-test-named-color-to-hex, css-test-format-rgba-alpha)
    (css-test-hex-to-rgb, css-test-rgb-to-named-color-or-hex)
    (css-test-cycle-color-format, css-test-hex-alpha): New tests for the
    changes mentioned above.
    
    * etc/NEWS: Mention the new command.
---
 etc/NEWS                              |   7 ++
 lisp/textmodes/css-mode.el            | 133 ++++++++++++++++++++++++++++++++--
 test/lisp/textmodes/css-mode-tests.el |  73 +++++++++++++++++++
 3 files changed, 207 insertions(+), 6 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index bec7753..1382f96 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -77,6 +77,13 @@ whether '"' is also replaced in 'electric-quote-mode'.  If 
non-nil,
 
 * Changes in Specialized Modes and Packages in Emacs 27.1
 
+** CSS mode
+
+---
+*** A new command 'css-cycle-color-format' for cycling between color
+formats (e.g. "black" => "#000000" => "rgb(0, 0, 0)") has been added,
+bound to 'C-c C-f'.
+
 ** Dired
 
 +++
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index b0e66d3..f098882 100644
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -32,12 +32,13 @@
 
 ;;; Code:
 
-(require 'eww)
 (require 'cl-lib)
 (require 'color)
+(require 'eww)
 (require 'seq)
 (require 'sgml-mode)
 (require 'smie)
+(require 'thingatpt)
 (eval-when-compile (require 'subr-x))
 
 (defgroup css nil
@@ -806,6 +807,7 @@ cannot be completed sensibly: `custom-ident',
 (defvar css-mode-map
   (let ((map (make-sparse-keymap)))
     (define-key map [remap info-lookup-symbol] 'css-lookup-symbol)
+    (define-key map "\C-c\C-f" 'css-cycle-color-format)
     map)
   "Keymap used in `css-mode'.")
 
@@ -936,11 +938,13 @@ cannot be completed sensibly: `custom-ident',
   "Skip blanks and comments."
   (while (forward-comment 1)))
 
-(cl-defun css--rgb-color ()
+(cl-defun css--rgb-color (&optional include-alpha)
   "Parse a CSS rgb() or rgba() color.
 Point should be just after the open paren.
 Returns a hex RGB color, or nil if the color could not be recognized.
-This recognizes CSS-color-4 extensions."
+This recognizes CSS-color-4 extensions.
+When INCLUDE-ALPHA is non-nil, the alpha component is included in
+the returned hex string."
   (let ((result '())
        (iter 0))
     (while (< iter 4)
@@ -952,8 +956,8 @@ This recognizes CSS-color-4 extensions."
             (number (string-to-number str)))
        (when is-percent
          (setq number (* 255 (/ number 100.0))))
-        ;; Don't push the alpha.
-        (when (< iter 3)
+        (if (and include-alpha (= iter 3))
+            (push (round (* number 255)) result)
           (push (min (max 0 (truncate number)) 255) result))
        (goto-char (match-end 0))
        (css--color-skip-blanks)
@@ -966,7 +970,11 @@ This recognizes CSS-color-4 extensions."
        (css--color-skip-blanks)))
     (when (looking-at ")")
       (forward-char)
-      (apply #'format "#%02x%02x%02x" (nreverse result)))))
+      (apply #'format
+             (if (and include-alpha (= (length result) 4))
+                 "#%02x%02x%02x%02x"
+               "#%02x%02x%02x")
+             (nreverse result)))))
 
 (cl-defun css--hsl-color ()
   "Parse a CSS hsl() or hsla() color.
@@ -1039,6 +1047,14 @@ This function simply drops any transparency."
   ;; Either #RGB or #RRGGBB, drop the "A" or "AA".
   (substring str 0 (if (> (length str) 5) 7 4)))
 
+(defun css--hex-alpha (hex)
+  "Return the alpha component of CSS color HEX.
+HEX can either be in the #RGBA or #RRGGBBAA format.  Return nil
+if the color doesn't have an alpha component."
+  (cl-case (length hex)
+    (5 (string (elt hex 4)))
+    (9 (substring hex 7 9))))
+
 (defun css--named-color (start-point str)
   "Check whether STR, seen at point, is CSS named color.
 Returns STR if it is a valid color.  Special care is taken
@@ -1381,6 +1397,111 @@ tags, classes and IDs."
                       (progn (insert ": ;")
                              (forward-char -1))))))))))
 
+(defun css--color-to-4-dpc (hex)
+  "Convert the CSS color HEX to four digits per component.
+CSS colors use one or two digits per component for RGB hex
+values.  Convert the given color to four digits per component.
+
+Note that this function handles CSS colors specifically, and
+should not be mixed with those in color.el."
+  (let ((six-digits (= (length hex) 7)))
+    (apply
+     #'concat
+     `("#"
+       ,@(seq-mapcat
+          (apply-partially #'make-list (if six-digits 2 4))
+          (seq-partition (seq-drop hex 1) (if six-digits 2 1)))))))
+
+(defun css--named-color-to-hex ()
+  "Convert named CSS color at point to hex format.
+Return non-nil if a conversion was made.
+
+Note that this function handles CSS colors specifically, and
+should not be mixed with those in color.el."
+  (save-excursion
+    (unless (or (looking-at css--colors-regexp)
+                (eq (char-before) ?#))
+      (backward-word))
+    (when (member (word-at-point) (mapcar #'car css--color-map))
+      (looking-at css--colors-regexp)
+      (let ((color (css--compute-color (point) (match-string 0))))
+        (replace-match color))
+      t)))
+
+(defun css--format-rgba-alpha (alpha)
+  "Return ALPHA component formatted for use in rgba()."
+  (let ((a (string-to-number (format "%.2f" alpha))))
+    (if (or (= a 0)
+            (= a 1))
+        (format "%d" a)
+      (string-remove-suffix "0" (number-to-string a)))))
+
+(defun css--hex-to-rgb ()
+  "Convert CSS hex color at point to RGB format.
+Return non-nil if a conversion was made.
+
+Note that this function handles CSS colors specifically, and
+should not be mixed with those in color.el."
+  (save-excursion
+    (unless (or (eq (char-after) ?#)
+                (eq (char-before) ?\())
+      (backward-sexp))
+    (when-let* ((hex (when (looking-at css--colors-regexp)
+                       (and (eq (elt (match-string 0) 0) ?#)
+                            (match-string 0))))
+                (rgb (css--hex-color hex)))
+      (seq-let (r g b)
+          (mapcar (lambda (x) (round (* x 255)))
+                  (color-name-to-rgb (css--color-to-4-dpc rgb)))
+        (replace-match
+         (if-let* ((alpha (css--hex-alpha hex))
+                   (a (css--format-rgba-alpha
+                       (/ (string-to-number alpha 16)
+                          (float (expt 16 (length alpha)))))))
+             (format "rgba(%d, %d, %d, %s)" r g b a)
+           (format "rgb(%d, %d, %d)" r g b))
+         t))
+      t)))
+
+(defun css--rgb-to-named-color-or-hex ()
+  "Convert CSS RGB color at point to a named color or hex format.
+Convert to a named color if the color at point has a name, else
+convert to hex format.  Return non-nil if a conversion was made.
+
+Note that this function handles CSS colors specifically, and
+should not be mixed with those in color.el."
+  (save-excursion
+    (when-let* ((open-paren-pos (nth 1 (syntax-ppss))))
+      (when (save-excursion
+              (goto-char open-paren-pos)
+              (looking-back "rgba?" (- (point) 4)))
+        (goto-char (nth 1 (syntax-ppss)))))
+    (when (eq (char-before) ?\))
+      (backward-sexp))
+    (skip-chars-backward "rgba")
+    (when (looking-at css--colors-regexp)
+      (let* ((start (match-end 0))
+             (color (save-excursion
+                      (goto-char start)
+                      (css--rgb-color t))))
+        (when color
+          (kill-sexp)
+          (kill-sexp)
+          (let ((named-color (seq-find (lambda (x) (equal (cdr x) color))
+                                       css--color-map)))
+            (insert (if named-color (car named-color) color)))
+          t)))))
+
+(defun css-cycle-color-format ()
+  "Cycle the color at point between different CSS color formats.
+Supported formats are by name (if possible), hexadecimal, and
+rgb()/rgba()."
+  (interactive)
+  (or (css--named-color-to-hex)
+      (css--hex-to-rgb)
+      (css--rgb-to-named-color-or-hex)
+      (message "It doesn't look like a color at point")))
+
 ;;;###autoload
 (define-derived-mode css-mode prog-mode "CSS"
   "Major mode to edit Cascading Style Sheets (CSS).
diff --git a/test/lisp/textmodes/css-mode-tests.el 
b/test/lisp/textmodes/css-mode-tests.el
index 1e58751..2be5772 100644
--- a/test/lisp/textmodes/css-mode-tests.el
+++ b/test/lisp/textmodes/css-mode-tests.el
@@ -244,6 +244,73 @@
       (should (member "body" completions))
       (should-not (member "article" completions)))))
 
+(ert-deftest css-test-color-to-4-dpc ()
+  (should (equal (css--color-to-4-dpc "#ffffff")
+                 (css--color-to-4-dpc "#fff")))
+  (should (equal (css--color-to-4-dpc "#aabbcc")
+                 (css--color-to-4-dpc "#abc")))
+  (should (equal (css--color-to-4-dpc "#fab")
+                 "#ffffaaaabbbb"))
+  (should (equal (css--color-to-4-dpc "#fafbfc")
+                 "#fafafbfbfcfc")))
+
+(ert-deftest css-test-named-color-to-hex ()
+  (dolist (item '(("black" "#000000")
+                  ("white" "#ffffff")
+                  ("salmon" "#fa8072")))
+    (with-temp-buffer
+      (css-mode)
+      (insert (nth 0 item))
+      (css--named-color-to-hex)
+      (should (equal (buffer-string) (nth 1 item))))))
+
+(ert-deftest css-test-format-rgba-alpha ()
+  (should (equal (css--format-rgba-alpha 0) "0"))
+  (should (equal (css--format-rgba-alpha 0.0) "0"))
+  (should (equal (css--format-rgba-alpha 0.00001) "0"))
+  (should (equal (css--format-rgba-alpha 1) "1"))
+  (should (equal (css--format-rgba-alpha 1.0) "1"))
+  (should (equal (css--format-rgba-alpha 1.00001) "1"))
+  (should (equal (css--format-rgba-alpha 0.10000) "0.1"))
+  (should (equal (css--format-rgba-alpha 0.100001) "0.1"))
+  (should (equal (css--format-rgba-alpha 0.2524334) "0.25")))
+
+(ert-deftest css-test-hex-to-rgb ()
+  (dolist (item '(("#000" "rgb(0, 0, 0)")
+                  ("#000000" "rgb(0, 0, 0)")
+                  ("#fff" "rgb(255, 255, 255)")
+                  ("#ffffff" "rgb(255, 255, 255)")
+                  ("#ffffff80" "rgba(255, 255, 255, 0.5)")
+                  ("#fff8" "rgba(255, 255, 255, 0.5)")))
+    (with-temp-buffer
+      (css-mode)
+      (insert (nth 0 item))
+      (css--hex-to-rgb)
+      (should (equal (buffer-string) (nth 1 item))))))
+
+(ert-deftest css-test-rgb-to-named-color-or-hex ()
+  (dolist (item '(("rgb(0, 0, 0)" "black")
+                  ("rgb(255, 255, 255)" "white")
+                  ("rgb(255, 255, 240)" "ivory")
+                  ("rgb(18, 52, 86)" "#123456")
+                  ("rgba(18, 52, 86, 0.5)" "#12345680")))
+    (with-temp-buffer
+      (css-mode)
+      (insert (nth 0 item))
+      (css--rgb-to-named-color-or-hex)
+      (should (equal (buffer-string) (nth 1 item))))))
+
+(ert-deftest css-test-cycle-color-format ()
+  (with-temp-buffer
+    (css-mode)
+    (insert "black")
+    (css-cycle-color-format)
+    (should (equal (buffer-string) "#000000"))
+    (css-cycle-color-format)
+    (should (equal (buffer-string) "rgb(0, 0, 0)"))
+    (css-cycle-color-format)
+    (should (equal (buffer-string) "black"))))
+
 (ert-deftest css-mdn-symbol-guessing ()
   (dolist (item '(("@med" "ia" "@media")
                   ("@keyframes " "{" "@keyframes")
@@ -301,6 +368,12 @@
   (should (equal (css--hex-color "#aabbcc") "#aabbcc"))
   (should (equal (css--hex-color "#aabbccdd") "#aabbcc")))
 
+(ert-deftest css-test-hex-alpha ()
+  (should (equal (css--hex-alpha "#abcd") "d"))
+  (should-not (css--hex-alpha "#abc"))
+  (should (equal (css--hex-alpha "#aabbccdd") "dd"))
+  (should-not (css--hex-alpha "#aabbcc")))
+
 (ert-deftest css-test-named-color ()
   (dolist (text '("@mixin black" "@include black"))
     (with-temp-buffer