;;; vm-fontlock.el --- colorization for VM presentation and summary buffers

;; Author: Noah Friedman <friedman@splode.com>
;; Created: 1994
;; Public domain

;; $Id: vm-fontlock.el,v 1.1 2017/10/13 01:24:28 friedman Exp $

;;; Commentary:
;;; Code:

(require 'vm-addons)
(require 'fmailutils)

(defvar vmfl-folder-font-lock-citation-faces
  '(font-lock-string-face
    font-lock-function-name-face
    font-lock-type-face
    font-lock-builtin-face
    font-lock-constant-face
    font-lock-comment-face
    font-lock-keyword-face
    font-lock-warning-face
    font-lock-variable-name-face))

(defconst vmfl-folder-cite-chars
  "[>}|\x00bb\x203a\x2bc8\x2192\x23f5\x25b6\x25ba\x276f]")

;; Needed by defn of vmfl-folder-font-lock-keywords
(defun vmfl-folder-font-lock-make-citation-level (n)
  (let* ((cite-chars  vmfl-folder-cite-chars)
         (cite-prefix "[:alpha:]")
         (cite-suffix "0-9_.@-`'\"")
         ;; Nested concats used to emphasize sub-grouping
         (citation (concat "\\(?:"
                           (concat "\\(?:[" cite-prefix "]+[" cite-suffix "]*\\)?"
                                   "\\(?:" cite-chars "[[:blank:]]*\\)")
                           "\\)"))
         (face (nth (mod (1- n) (length vmfl-folder-font-lock-citation-faces))
                    vmfl-folder-font-lock-citation-faces)))

    ;; Use MATCH-ANCHORED to effectively anchor the regexp left side.
    `(,cite-chars
      (,(concat "\\=[[:blank:]]*" citation "\\{" (number-to-string (1- n)) "\\}"
                "\\(" citation ".*\\)")
       (beginning-of-line) (end-of-line)
       (1 ,face keep t)))))

;; $1 contains matched header name
;; $2 contains header contents, including any continuation lines.
;; The length of the contents actually highlighted will tend to be limited
;; by `jit-lock-chunk-size'.
(defun vmfl-folder-make-header-font-lock-regexp (&rest headers)
  (format "^\\(%s\\):[[:blank:]]+\\(\\(?:.+\\(?:\n[[:blank:]]\\)?\\)+\\)"
          (mapconcat 'identity headers "\\|")))

(defvar vmfl-folder-font-lock-keywords
  (let* ((h 'vmfl-folder-make-header-font-lock-regexp))
    `((,(funcall h "\\(?:resent-\\)?from") (2 font-lock-function-name-face))
      ;;(,(funcall h "to" "b?cc" "newsgroups") (2 font-lock-constant-face))
      ;;(,(funcall h "reply-to") (2 font-lock-keyword-face))
      (,(funcall h "subject") (2 font-lock-type-face))

      (vmfl-folder-font-lock-signature-matcher
       (0 font-lock-comment-face t))

      ,@(nreverse (mapcar 'vmfl-folder-font-lock-make-citation-level
                          '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)))
      )))

;; Make your known addresses stand out in recipient list so you know if the
;; message was explicitly addressed to you.
;; Uses `vm-multdom-user-addresses'
(defun vmfl-folder-font-lock-match-me-multdom (&optional face)
  (setq vmfl-folder-font-lock-keywords
        (cons `(,(vmfl-folder-make-header-font-lock-regexp
                  "\\(?:resent-\\)?\\(?:to\\|b?cc\\)")
                (,(vm-multdom-address-list-regexp
                   vm-multdom-user-addresses)
                 (progn
                   (goto-char (match-beginning 2)) ; Go to start for match
                   (match-end 2))    ; Return end of header contents region
                 nil
                 (0 ,(or face 'font-lock-comment-face) t)))
              vmfl-folder-font-lock-keywords)))

(defun vmfl-folder-font-lock-signature-matcher (&rest ignore)
  (let ((region (vma-signature-region)))
    (cond ((and region
                ;; If this region is already highlighted, don't do it
                ;; again; that can result in an infinite loop if we're
                ;; called again.
                (null (plist-get (text-properties-at (car region)) 'face)))
           (set-match-data region)
           (goto-char (cadr region)))
          (t nil))))

(defun vmfl-font-lock-default-unfontify-region (beg end)
  "Only permit unfontification in the header region."
  (let* ((mail-header-separator "")
         (headers-end (fmailutils-header-separator-position)))
    (setq beg (min beg headers-end)
          end (min end headers-end))
    (font-lock-default-unfontify-region beg end)))

;;;###autoload
(defun vmfl-folder-font-lock-setup ()
  (set (make-local-variable 'font-lock-defaults)
       '(vmfl-folder-font-lock-keywords t t))

  (set (make-local-variable 'font-lock-unfontify-region-function)
       'vmfl-font-lock-default-unfontify-region)

  (font-lock-mode 1))

(provide 'vm-fontlock)

;;; vm-fontlock.el ends here.