[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#9205: 24.0.50; colored mark in vc mode-line
From: |
Lars Ingebrigtsen |
Subject: |
bug#9205: 24.0.50; colored mark in vc mode-line |
Date: |
Tue, 01 Mar 2016 12:47:55 +1100 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/25.1.50 (gnu/linux) |
Lars Ingebrigtsen <larsi@gnus.org> writes:
> I started to work on this now, but I thought I'd do it with SVGs, since
> the size of the mode line can vary, and SVGs can be made on the fly.
>
> However, I'm having trouble creating an SVG with transparent
> backgrounds, and it needs to be that, because the mode line changes
> background colour when the window is selected or not.
>
> Doesn't Emacs support SVGs with transparent backgrounds?
Apparently not...
Anyway, here's as far as I got before I discovered the problem. We
could go with an XPM instead, but it would only approximately match the
height of the mode line, so I'm not sure it's worth it...
diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el
index 0c1718e..4a7acb8 100644
--- a/lisp/vc/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -717,6 +717,32 @@ vc-mode-line
(force-mode-line-update)
backend)
+(defun vc--face-color (color)
+ (concat
+ "#"
+ (mapconcat
+ (lambda (elem)
+ (format "%02x" (round (* elem 256))))
+ (color-name-to-rgb color)
+ "")))
+
+(defun vc--color-status (string color)
+ (if (not (image-type-available-p 'svg))
+ string
+ (propertize string
+ 'display
+ (let* ((height (- (window-font-height nil 'mode-line) 6))
+ (svg (svg-create height height)))
+ (svg-rectangle svg 0 0 height height
+ :fill-color (vc--face-color
+ (face-background 'mode-line)))
+ (svg-circle svg (/ height 2) (/ height 2) (/ height 2)
+ :fill-color color)
+ (let ((image (svg-image svg)))
+ (setf (image-property image :ascent) 80)
+ (setf (image-property image :scale) 1)
+ image)))))
+
(defun vc-default-mode-line-string (backend file)
"Return a string for `vc-mode-line' to put in the mode line for FILE.
Format:
@@ -739,11 +765,11 @@ vc-default-mode-line-string
(eq state 'needs-update))
(setq state-echo "Up to date file")
(setq face 'vc-up-to-date-state)
- (concat backend-name "-" rev))
+ (concat backend-name (vc--color-status "-" "green") rev))
((stringp state)
(setq state-echo (concat "File locked by" state))
(setq face 'vc-locked-state)
- (concat backend-name ":" state ":" rev))
+ (concat backend-name (vc--color-status ":" "orange") state ":" rev))
((eq state 'added)
(setq state-echo "Locally added file")
(setq face 'vc-locally-added-state)
@@ -751,22 +777,22 @@ vc-default-mode-line-string
((eq state 'conflict)
(setq state-echo "File contains conflicts after the last merge")
(setq face 'vc-conflict-state)
- (concat backend-name "!" rev))
+ (concat backend-name (vc--color-status "!" "red") rev))
((eq state 'removed)
(setq state-echo "File removed from the VC system")
(setq face 'vc-removed-state)
- (concat backend-name "!" rev))
+ (concat backend-name (vc--color-status "!" "red") rev))
((eq state 'missing)
(setq state-echo "File tracked by the VC system, but missing from
the file system")
(setq face 'vc-missing-state)
- (concat backend-name "?" rev))
+ (concat backend-name (vc--color-status "?" "purple") rev))
(t
;; Not just for the 'edited state, but also a fallback
;; for all other states. Think about different symbols
;; for 'needs-update and 'needs-merge.
(setq state-echo "Locally modified file")
(setq face 'vc-edited-state)
- (concat backend-name ":" rev)))
+ (concat backend-name (vc--color-status ":" "blue") rev)))
'face face
'help-echo (concat state-echo " under the " backend-name
" version control system"))))
--
(domestic pets only, the antidote for overdose, milk.)
bloggy blog: http://lars.ingebrigtsen.no