;;
;; 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)