;; ;; dot-gnus-colourization.el --- Colours and faces for Gnus. ;; (require 'cl) ; For Puff the Magic Highlighter ;; A couple of definitions; which groups are `important' to me and which are not. ;; (These have specific levels.) This is complicated by the need for mail groups ;; to have higher levels than news groups, so that they are accessible even when ;; the news server is down. (defvar nix-group-important-group 3 "The subscription level of a group that is important to us.") (defvar nix-group-unimportant-group 4 "The subscription level of a group that is not important to us.") (defvar nix-group-important-mail-group 1 "The subscription level of a mail group that is important to us.") (defvar nix-group-unimportant-mail-group 2 "The subscription level of a mail group that is not important to us.") ;;; Generic group-specific combinatorial fontification support. ;; This allows the configuration of certain simple fontification rules ;; in an alist rather than having to resort to (very ugly) code in the ;; `gnus-group-highlight' variable. ;; TODO: genericize to summary fontification as well. (defvar nix-gnus-conditions '(unread ticked important) "A list of conditions that can apply to groups. These are used to determine how to fontify the groups; see `nix-gnus-condition-face-name-alist', `nix-gnus-base-face-plist', `nix-gnus-face-replace-alist', and `nix-gnus-condition-code-ent-alist'. Note that this list should consist solely of freely recombinable properties (i.e. the properties should form a strict mathematical set); if the list of properties you wish to check for is not freely recombinable, you will probably not want to check for the non-freely- recombinable elements using this mechanism. Take care: A power set of faces and code to set them is constructed; so having more than a few conditions becomes exceedingly slow very, very fast.") (defvar nix-gnus-condition-face-name-alist '((unread . "unread") (ticked . "ticked") (important . "important") (t . "base")) "An alist mapping from conditions to face names. The complete name of a face is constructed from these names, concatenated, with a prefix and suffix to signify their facehood. The `t' entry is used if none of the others apply to a given face. For the list of valid conditions, see `nix-gnus-conditions'.") (defvar nix-gnus-condition-code-fragment-alist '((unread . ((> unread 0) (= unread 0))) (ticked . ((> ticked 0) (= ticked 0))) (important . ((or (= level nix-group-important-group) (= level nix-group-important-mail-group)) (or (= level nix-group-unimportant-group) (= level nix-group-unimportant-mail-group))))) "An alist mapping from conditions to code to test for them. The syntax is ((condition . (IF-TRUE IF-FALSE)) ...) The code should be suitable for insertion into the `gnus-group-highlight' variable, and it should be combinable with an `and' with other code fragments from this variable, in any order. All valid conditions must be handled by this code, or `nix-construct-gnus-group-highlight' will fail. For the list of valid conditions, see `nix-gnus-conditions'.") ; The base group colour is light grey; unread articles make it white, ticked ; ones make it italicized, unsubbing darkens it and zombifying or killing ; darkens it even more. (defvar nix-gnus-base-face-plist '(:foreground "LightGrey") "The `basic' face for group colours, as accepted by `set-face-attribute'. This is for bog standard unimportant groups with nothing unread and nothing ticked in them.") (defvar nix-gnus-face-replace-alist '(((unread) . (:foreground "White")) ((ticked) . (:slant italic)) ((important) . (:weight bold)) ((unread ticked) . (:foreground "White" :slant italic)) ((unread important) . (:foreground "White" :weight bold)) ((important ticked) . (:weight bold :slant italic)) ((unread important ticked) . (:foreground "White" :weight bold :slant italic))) "Things to replace in the `nix-gnus-base-face' when conditions are true. This is an alist mapping conditions to a plist to merge with the `nix-gnus-base-face-plist'. If a component is not specified, it is assumed to be false. For the list of valid conditions, see `nix-gnus-conditions'.") (defun nix-construct-gnus-group-highlight () "Construct code for insertion into the `gnus-group-highlight', and return it. The code constructed is dependent upon `nix-gnus-face-replace-alist', and things referenced therefrom. Also, create the appropriate faces for that insertion to work. Iterate through all combinations of the `nix-gnus-conditions', generate faces for them with names specified in the `nix-gnus-condition-face-name-alist' and colours specified in the `nix-gnus-base-face-plist' and `gnus-gnus-face-replace-alist',and build the code to enable these faces at the appropriate times from the `nix-gnus-condition-code-fragment-alist'. The code generated by this function will probably be quite large, but it is hard to byte-compile all of it, as it is assembled from small pieces and the resulting variable is not a Lisp form, but merely contains Lisp forms." ;; Nearly all the work in here is done in the `let' form; possibly this looks ;; ugly but it's much neater than what it replaces. ;; The set of `face-plist' is rather complicated; we essentially look up the set ;; in `nix-gnus-face-replace-plist' that corresponds (in a set-wise unordered ;; fashion, thanks to `set-exclusive-or') to the combination of conditions we ;; are working on, prepend it to the base plist, then dump all the conditions ;; in the base plist that are duplicated earlier in the list, so the ;; `nix-gnus-face-replace-alist' magically overrides the ;; `nix-gnus-base-face-plist'. ;; The `face-name' calculation is a simple `mapconcat' going from condition names ;; to strings, complicated by the need to have something in the face name when ;; none of the conditions are true; i.e. `nix-group-base-face' is a better name ;; than `nix-group--face'; so we work out the variable part of the name separately, ;; then put in something else if its length is zero. Finally, we `intern' the ;; name, to transform it into a symbol. ;; (The nested let is stylistically iffy, but too elegant to leave out, I think.) ;; Likewise the `face-code' variable; only this is substituting in Lisp code to ;; compute the truth of the `condition'. This assumes that `not present' means ;; `nil', and works through the total set of conditions rather than the set ;; that was provided, so that it can handle those that aren't present; e.g. when ;; `unread' is not present, we don't mean `we don't care about unread' but rather ;; `only show for groups with some read articles'. ;; And it all takes place in that damned let form. This code could be some kind ;; of exhibit for the virtues of named let; but unfortunately elisp does not ;; support it :( (mapcar #'(lambda (condition-set) ;; The plist corresponding to this face's properties. (let* ((face-plist (append (cdr (assoc* condition-set nix-gnus-face-replace-alist :test-not 'set-exclusive-or)) nix-gnus-base-face-plist)) ;; The name this face should have. (face-name ;; FIXME: this name will have to change when we get summary ;; colourization. (intern (concat "nix-group-" ; Get the variable part of the name right, defaulting in ; the default entry in the `nix-gnus-condition-face-name-alist' ; if none of the conditions apply. (let ((partial-face-name (mapconcat #'(lambda (single-face-condition) (cdr (or (assq single-face-condition nix-gnus-condition-face-name-alist)))) condition-set "-"))) (if (= (length partial-face-name) (length condition-set)) (cdr (assq t nix-gnus-condition-face-name-alist)) partial-face-name))))) ;; The code required in the `gnus-group-highlight' to handle these ;; conditions. For each potential code fragment in the ;; `nix-gnus-condition-code-fragment-alist', if it is in the ;; set we are dealing with, substitute the true-branch fragment; ;; otherwise subtitute the false-branch one; and substitute in the ;; `face-name'. (face-code (cons (append '(and) (mapcar #'(lambda (potential-condition-and-code) (if (memq (car potential-condition-and-code) condition-set) (cadr potential-condition-and-code) (caddr potential-condition-and-code))) nix-gnus-condition-code-fragment-alist)) face-name))) (make-face face-name) (apply 'set-face-attribute face-name nil face-plist) face-code)) (append (power-set nix-gnus-conditions) '(nil)))) ;; Make all the faces handled by the combinatorial engine, and additionally add ;; code for unsubbed, killed, and zombie groups --- these do not have read or ;; ticked statuses recorded and are all less important than `unimportant', so ;; the combinatorial engine is not appropriate for them. ;; Make the faces for the dead groups and fontify them (zombie and killed groups ;; are really dark). (mapc #'(lambda (face) (make-face face)) '(nix-group-unsubbed-face nix-group-zombie-face nix-group-killed-face)) (set-face-attribute 'nix-group-unsubbed-face :foreground "Grey" :weight 'bold) (set-face-attribute 'nix-group-zombie-face :foreground "DarkGrey") (set-face-attribute 'nix-group-killed-face :foreground "DarkGrey" :strike-through t) ; Finally, call the combinatorial engine. (setq gnus-group-highlight (nconc (nix-construct-gnus-group-highlight) '(((and (>= level gnus-level-subscribed) ; Groups of various levels of deadness (< level gnus-level-zombie)) . nix-group-unsubbed-face) ((and (>= level gnus-level-zombie) (< level gnus-level-killed)) . nix-group-zombie-face) ((<= level gnus-level-killed) . nix-group-killed-face)))) ; Make the x-faces visible on a dark background (make-face 'gnus-x-face) (set-face-background 'gnus-x-face (face-background 'default)) (set-face-foreground 'gnus-x-face "green") (provide 'dot-gnus-colourization)