;;; -*- lexical-binding: t -*-
;;;
;;; this file:
;;;   http://user.it.uu.se/~embe8573/emacs-init/my-faces.el
;;;   https://dataswamp.org/~incal/emacs-init/my-faces.el

(require 'erc-button)
(require 'erc-match)
(require 'gnus-spec)
(require 'org-faces)
(require 'sh-script)
(require 'w3m-form)

(defun set-all-faces (fg &optional bg weight)
  (let ((faces))
    (mapatoms (lambda (s)
                (when (facep s)
                  (push (symbol-name s) faces) )))
    (dolist (f faces)
      (set-face-attribute (intern f) nil
                          :foreground fg)
                          :background (or bg "black")
                          :weight     (or weight 'normal)
                          :italic     nil
                          ) ))
;; (set-all-faces "red")

(defun what-face (pos)
  (interactive "d")
  (let ((face (or (get-char-property pos 'face)
                  (get-char-property pos 'read-cf-name) )))
    (message "face: %s" (or face "no face")) ))

(defun set-face (face fg bold &optional bg)
  (let ((bld (cond ((eq bold t)   'bold)
                   ((eq bold nil) 'normal)
                   (t              bold) )))
    (set-face-attribute face nil
                        :foreground fg
                        :background bg
                        :weight     bld) ))
(defalias 'sfa #'set-face)

(defun copy-face-attributes (src dst &rest more-faces)
  (when (and (facep src)
             (facep dst) )
    (dolist (d (cons dst more-faces))
      (let ((fg (face-attribute src :foreground nil 'default))
            (bg (face-attribute src :background nil 'default))
            (wt (face-attribute src :weight     nil 'default)) )
        (sfa d fg wt bg) ))))
(defalias 'cpf #'copy-face-attributes)

(font-lock-add-keywords 'emacs-lisp-mode
 '(
   ("font-lock-builtin-face"              .  font-lock-builtin-face)
   ("font-lock-comment-delimiter-face"    .  font-lock-comment-delimiter-face)
   ("font-lock-comment-face"              .  font-lock-comment-face)
   ("font-lock-constant-face"             .  font-lock-constant-face)
   ("font-lock-doc-face"                  .  font-lock-doc-face)
   ("font-lock-function-name-face"        .  font-lock-function-name-face)
   ("font-lock-keyword-face"              .  font-lock-keyword-face)
   ("font-lock-negation-char-face"        .  font-lock-negation-char-face)
   ("font-lock-preprocessor-face"         .  font-lock-preprocessor-face)
   ("font-lock-reference-face"            .  font-lock-reference-face)
   ("font-lock-regexp-grouping-backslash" . 'font-lock-regexp-grouping-backslash)
   ("font-lock-regexp-grouping-construct" . 'font-lock-regexp-grouping-construct)
   ("font-lock-string-face"               .  font-lock-string-face)
   ("font-lock-type-face"                 .  font-lock-type-face)
   ("font-lock-variable-name-face"        .  font-lock-variable-name-face)
   ("font-lock-warning-face"              .  font-lock-warning-face)
   )
 t)

(sfa 'bold                                "yellow"  nil)
(sfa 'bold-italic                         "green"   t)
(sfa 'button                              "green"   t)
(sfa 'default                             "white"   nil)
(sfa 'italic                              "yellow"  t)
(sfa 'minibuffer-prompt                   "cyan"    nil)
(sfa 'nobreak-space                       "black"   t)
(sfa 'region                              "white"   t "white") ; <-- this
(sfa 'underline                           "yellow"  t)
(sfa 'warning                             "red"     t)

(sfa  font-lock-builtin-face              "cyan"    nil)
(sfa  font-lock-comment-face              "blue"    t)
(sfa  font-lock-constant-face             "magenta" t)
(sfa  font-lock-doc-face                  "black"   t)
(sfa  font-lock-function-name-face        "yellow"  nil)
(sfa  font-lock-keyword-face              "green"   t)
(sfa  font-lock-negation-char-face        "black"   t)
(sfa  font-lock-preprocessor-face         "cyan"    t)
(sfa  font-lock-string-face               "green"   nil)
(sfa  font-lock-type-face                 "magenta" nil)
(sfa  font-lock-variable-name-face        "yellow"  t)
(sfa 'font-lock-regexp-grouping-backslash "blue"    nil)
(sfa 'font-lock-regexp-grouping-construct "red"     t)
(cpf 'font-lock-comment-face 'font-lock-comment-delimiter-face)
(cpf 'warning                'font-lock-warning-face)

;; unsorted
(sfa 'completions-common-part             "green"   nil)
(sfa 'Man-overstrike                      "yellow"  nil)
(sfa 'org-block                           "white"   t)
(sfa 'sh-escaped-newline                  "red"     t)
(sfa 'tabulated-list-fake-header          "black"   t)

;; package
(sfa 'package-description                 "blue"    t)
(sfa 'package-name                        "white"   t)
(sfa 'package-status-new                  "green"   t)
(sfa 'package-status-available            "yellow"  t)
(sfa 'package-status-built-in             "green"   nil)
(sfa 'package-status-dependency           "black"   t)
(sfa 'package-status-installed            "yellow"  nil)
(sfa 'package-help-section-name           "blue"    t)

;; markdown
(require 'markdown-mode)
(sfa 'markdown-header-delimiter-face      "green"   nil)
(sfa 'markdown-header-face-1              "white"   t)
(sfa 'markdown-header-face-2              "green"   t)
(sfa 'markdown-markup-face                "black"   t)
(sfa 'markdown-metadata-key-face          "white"   t)
(sfa 'markdown-metadata-value-face        "blue"    t)
(sfa 'markdown-plain-url-face             "blue"    t)
(sfa 'markdown-url-face                   "green"   t)
(sfa 'markdown-footnote-marker-face       "green"   t)

;; erc
(sfa 'erc-action-face                     "white"   t)
(sfa 'erc-command-indicator-face          "cyan"    nil)
(sfa 'erc-current-nick-face               "white"   t)
(sfa 'erc-direct-msg-face                 "magenta" t)
(sfa 'erc-fool-face                       "yellow"  nil)
(sfa 'erc-header-line                     "yellow"  nil "black")
(sfa 'erc-input-face                      "green"   nil)
(sfa 'erc-inverse-face                    "magenta" nil)
(sfa 'erc-keyword-face                    "white"   nil)
(sfa 'erc-nick-default-face               "magenta" t)
(sfa 'erc-nick-msg-face                   "white"   nil)
(sfa 'erc-notice-face                     "black"   t)
(sfa 'erc-pal-face                        "blue"    nil)
(sfa 'erc-prompt-face                     "white"   nil "black")
(sfa 'erc-timestamp-face                  "red"     t)

(cpf 'erc-current-nick-face 'erc-my-nick-face)

;; message / gnus
(sfa 'message-mml                         "black"   t)

(sfa 'gnus-server-opened                  "green"   nil)
(sfa 'gnus-server-denied                  "red"     t)

(sfa 'gnus-header-content                 "black"   t) ; DNC ?
(sfa 'gnus-header-from                    "blue"    t)

(sfa 'message-separator                   "white"   nil)

(sfa 'message-header-cc                   "cyan"    nil)
(sfa 'message-header-name                 "green"   nil)
(sfa 'message-header-newsgroups           "magenta" t)
(sfa 'message-header-other                "black"   t)
(sfa 'message-header-subject              "yellow"  nil)
(sfa 'message-header-to                   "white"   t)
(sfa 'message-header-xheader              "black"   nil)

(cpf 'message-header-cc         'gnus-header-cc)
(cpf 'message-header-name       'gnus-header-name)
(cpf 'message-header-newsgroups 'gnus-header-newsgroups)
(cpf 'message-header-subject    'gnus-header-subject)

(setq gnus-face-0 font-lock-comment-face)
(setq gnus-face-1 font-lock-constant-face)
(setq gnus-face-2 font-lock-doc-face)
(setq gnus-face-3 font-lock-function-name-face)
(setq gnus-face-4 font-lock-variable-name-face)

(sfa 'gnus-cite-1                         "blue"    t)
(sfa 'gnus-cite-2                         "green"   nil)
(sfa 'gnus-cite-3                         "magenta" nil)
(sfa 'gnus-cite-4                         "magenta" t)
(sfa 'gnus-cite-5                         "blue"    t)
(sfa 'gnus-cite-attribution               "blue"    t) ; DNC ?

(sfa 'gnus-group-mail-1                   "yellow"  nil)
(sfa 'gnus-group-mail-3                   "cyan"    nil)
(sfa 'gnus-group-news-3                   "green"   t)
(sfa 'gnus-group-news-3-empty             "white"   nil)
(sfa 'gnus-group-news-6                   "black"   t)

(cpf 'gnus-group-news-6 'gnus-group-mail-1-empty
                        'gnus-group-mail-3-empty
                        'gnus-group-mail-low
                        'gnus-group-mail-low-empty
                        'gnus-group-news-6-empty)

(sfa 'gnus-summary-normal-ancient         "magenta" t)
(sfa 'gnus-summary-normal-read            "green"   nil)
(sfa 'gnus-summary-normal-ticked          "yellow"  nil)
(sfa 'gnus-summary-normal-unread          "white"   nil)
(sfa 'gnus-summary-selected               "black"   nil "white")

;; mode line
(sfa 'mode-line                           "blue"    t    "white")
(sfa 'mode-line-buffer-id                 nil       t    "white")
(sfa 'mode-line-emphasis                  "red"     t)
(sfa 'mode-line-highlight                 "red"     t)
(sfa 'mode-line-inactive                  "green"   t    "white")

;; paren
(sfa 'show-paren-match                    "white"   t    "green")
(sfa 'show-paren-mismatch                 "white"   t    "red")

;; dired
(sfa 'dired-directory                     "blue"    t)
(sfa 'dired-header                        "green"   nil)
(sfa 'dired-ignored                       "black"   t)
(sfa 'dired-mark                          "yellow"  nil)
(sfa 'dired-symlink                       "cyan"    nil)

(cpf 'dired-mark 'dired-flagged 'dired-marked)

;; w3m
(sfa 'w3m-current-anchor                  "yellow"  nil)
(sfa 'w3m-form                            "white"   t)
(sfa 'w3m-form-button                     "black"   nil  "yellow")
(sfa 'w3m-image                           "black"   nil  "white")
(sfa 'w3m-image-anchor                    "black"   nil  "green")

(let ((w3m-bg "black"))
  (sfa 'w3m-tab-background                w3m-bg    nil)
  (sfa 'w3m-tab-selected                  w3m-bg    nil  "cyan") ; backwards?
  (sfa 'w3m-tab-selected-retrieving       w3m-bg    t    "white")
  (sfa 'w3m-tab-unselected                w3m-bg    t    "black") )

(cpf 'w3m-tab-unselected 'w3m-tab-unselected-unseen
                         'w3m-tab-unselected-retrieving)

;; comint
(sfa 'comint-highlight-input              "white"   nil)
(sfa 'comint-highlight-prompt             "white"   nil)

;; compilation
(sfa 'compilation-info                    "yellow"  t)

;; info
(sfa 'Info-quoted                         "magenta" t)

(sfa 'info-header-node                    "yellow"  nil)
(sfa 'info-menu-header                    "magenta" t)
(sfa 'info-menu-star                      "white"   nil)
(sfa 'info-title-1                        "green"   t)
(sfa 'info-title-2                        "blue"    t)
(sfa 'info-title-3                        "green"   t)
(sfa 'info-xref                           "cyan"    nil)

(cpf 'info-xref 'info-xref-visited 'info-header-xref)

(cpf 'bold        'erc-bold-face
                  'markdown-bold-face
                  'w3m-bold)

(cpf 'bold-italic 'gnus-emphasis-bold)

(cpf 'button      'browse-url-button
                  'erc-button
                  'gnus-button
                  'markdown-link-face
                  'w3m-anchor)

(cpf 'default     'erc-default-face)

(cpf 'italic      'link
                  'markdown-italic-face
                  'w3m-italic)

(cpf 'underline   'gnus-emphasis-underline
                  'erc-underline-face
                  'Man-underline)

(cpf 'warning     'dired-perm-write
                  'erc-dangerous-host-face
                  'erc-error-face)

(cpf 'w3m-anchor  'w3m-arrived-anchor)