From: Lars Ingebrigtsen <larsi@gnus.org>
To: "Peter Münster" <pmlists@free.fr>
Cc: 9205@debbugs.gnu.org, "Stefan Reichör" <stefan@xsteve.at>,
"Stefan Monnier" <monnier@IRO.UMontreal.CA>,
"Chong Yidong" <cyd@gnu.org>
Subject: bug#9205: 24.0.50; colored mark in vc mode-line
Date: Tue, 01 Mar 2016 12:47:55 +1100 [thread overview]
Message-ID: <877fhn3r5g.fsf@gnus.org> (raw)
In-Reply-To: <87bn6z3rfo.fsf@gnus.org> (Lars Ingebrigtsen's message of "Tue, 01 Mar 2016 12:41:47 +1100")
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
next prev parent reply other threads:[~2016-03-01 1:47 UTC|newest]
Thread overview: 20+ messages / expand[flat|nested] mbox.gz Atom feed top
2011-07-29 11:13 bug#9205: 24.0.50; colored mark in vc mode-line Peter Münster
2012-04-10 23:56 ` Lars Magne Ingebrigtsen
2012-04-11 6:43 ` Chong Yidong
2012-04-11 7:39 ` Stefan Reichör
2012-04-12 13:39 ` Lars Magne Ingebrigtsen
2012-04-12 14:23 ` Peter Münster
2012-04-12 16:07 ` Stefan Monnier
2012-04-12 16:09 ` Lars Magne Ingebrigtsen
2012-04-12 18:22 ` Stefan Monnier
2012-04-12 18:24 ` Lars Magne Ingebrigtsen
2012-04-12 18:51 ` Peter Münster
2016-03-01 1:41 ` Lars Ingebrigtsen
2016-03-01 1:47 ` Lars Ingebrigtsen [this message]
2016-03-01 2:05 ` Óscar Fuentes
2016-03-01 2:14 ` Lars Ingebrigtsen
2016-03-01 2:24 ` Óscar Fuentes
2016-03-01 3:05 ` Lars Ingebrigtsen
2016-03-09 23:49 ` Juri Linkov
2019-06-27 16:27 ` Lars Ingebrigtsen
2012-04-12 14:36 ` Stefan Monnier
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=877fhn3r5g.fsf@gnus.org \
--to=larsi@gnus.org \
--cc=9205@debbugs.gnu.org \
--cc=cyd@gnu.org \
--cc=monnier@IRO.UMontreal.CA \
--cc=pmlists@free.fr \
--cc=stefan@xsteve.at \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).