;;; markchars.el --- Mark chars fitting certain characteristics
;;
;; Author: Lennart Borgman (lennart O borgman A gmail O com)
;; Contributhor: Ted Zlatanov <tzz@lifelogs.com>
;; Created: 2010-03-22 Mon
;; Version: 0.2.0
;; Last-Updated: 2011-04-15
;; URL:
;; Keywords:
;; Compatibility:
;;
;; Features that can be used by this library:
;;
;;   `idn'.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; Mark special chars, by default nonascii, non-IDN chars, in modes
;; where they may be confused with regular chars. See `markchars-mode'
;; and `markchars-what'.  There are two modes: confusable detection
;; (where we look for mixed scripts within a word, without using the
;; http://www.unicode.org/reports/tr39/ confusable tables) and pattern
;; detection (where any regular expressions can be matched).
;;
;; The marked text will have the 'markchars property set to either
;; 'confusable or 'pattern and the face set to either
;; `markchars-face-confusable' or `markchars-face-pattern'
;; respectively.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Change log:
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:

(require 'idn nil t)

;;;###autoload
(defgroup markchars nil
  "Customization group for `markchars-mode'."
  :group 'convenience)

(defface markchars-light
  '((t (:underline "light blue")))
  "Light face for `markchars-mode' char marking."
  :group 'markchars)

(defface markchars-heavy
  '((t (:underline "magenta")))
  "Heavy face for `markchars-mode' char marking."
  :group 'markchars)

(defface markchars-white
  '((t (:underline "white")))
  "White face for `markchars-mode' char marking."
  :group 'markchars)

(defcustom markchars-face-pattern 'markchars-heavy
  "Pointer to face used for marking matched patterns."
  :type 'face
  :group 'markchars)

(defcustom markchars-face-confusable 'markchars-light
  "Pointer to face used for marking confusables."
  :type 'face
  :group 'markchars)

(defcustom markchars-face-nonidn 'markchars-white
  "Pointer to face used for marking non-IDN characters."
  :type 'face
  :group 'markchars)

(defcustom markchars-simple-pattern "[[:nonascii:]]+"
  "Regexp for characters to mark, a simple pattern.

By default it matches nonascii-chars."
  :type 'regexp
  :group 'markchars)

(defcustom markchars-what
  `(markchars-simple-pattern
    markchars-confusables
    ,@(when (fboundp 'idn-is-recommended) '(markchars-nonidn-fun)))
  "Things to mark, a list of regular expressions or symbols."
  :type `(repeat (choice :tag "Marking choices"
                         (const
                          :tag "Non IDN chars (Unicode.org tr39 suggestions)"
                          markchars-nonidn-fun)
                         (const :tag "Confusables" markchars-confusables)
                         (const :tag "`markchars-simple-pattern'"
                                markchars-simple-pattern)
                         (regexp :tag "Arbitrary pattern")))
  :group 'markchars)

(make-obsolete-variable 'markchars-keywords 'markchars-what "markchars.el 0.2")

(defvar markchars-used-keywords nil
  "Keywords for font lock.")
(put 'markchars-used-keywords 'permanent-local t)

(defun markchars-set-keywords ()
  "Set `markchars-used-keywords' from options."
  (set (make-local-variable 'markchars-used-keywords)
       (delq nil (mapcar (lambda (what)
                           (when (eq what 'markchars-simple-pattern)
                             (setq what markchars-simple-pattern))
                           (cond
                            ((eq what 'markchars-nonidn-fun)
                             (list
                              "\\<\\w+\\>"
                              (list 0 '(markchars--render-nonidn
                                        (match-beginning 0)
                                        (match-end 0)))))
                            ((eq what 'confusables)
                             (list
                              "\\<\\w+\\>"
                              (list 0 '(markchars--render-confusables
                                        (match-beginning 0)
                                        (match-end 0)))))
                            ((stringp what)
                             (list
                              what
                              (list 0 '(markchars--render-pattern
                                        (match-beginning 0)
                                        (match-end 0)))))))
                         markchars-what))))

(defun markchars--render-pattern (beg end)
  "Assign markchars pattern properties between BEG and END."
  (put-text-property beg end 'face markchars-face-pattern)
  (put-text-property beg end 'markchars 'pattern))

(defun markchars--render-confusables (beg end)
  "Assign markchars confusable properties between BEG and END."
  (let* ((text (buffer-substring-no-properties beg end))
         (scripts (mapcar
                   (lambda (c) (aref char-script-table c))
                   (string-to-list text)))
         ;; `scripts-extra' is not nil is there was more than one script
         (scripts-extra (delq (car scripts) scripts)))
    (when scripts-extra
      (put-text-property beg end 'markchars 'confusable)
      (put-text-property beg end 'face markchars-face-confusable))))

(defun markchars--render-nonidn (beg end)
  "Assign markchars confusable properties between BEG and END."
  (save-excursion
    (goto-char beg)
    (while (<= (point) end)
      (let ((c (char-after)))
        (when (and (> c 256)
                   (not (idn-is-recommended c)))
          (put-text-property (point) (1+ (point)) 'markchars 'nonidn)
          (put-text-property (point) (1+ (point)) 'face markchars-face-nonidn)))
      (forward-char))))

;;;###autoload
(define-minor-mode markchars-mode
  "Mark special characters.
Which characters to mark are defined by `markchars-pattern'.

The default is to mark nonascii chars with a magenta underline."
  :group 'markchars
  :lighter " Mchar"
  (if markchars-mode
      (progn
        (markchars-set-keywords)
        (let ((props (make-local-variable 'font-lock-extra-managed-props)))
          (add-to-list props 'markchars))
        (font-lock-add-keywords nil markchars-used-keywords))
    (font-lock-remove-keywords nil markchars-used-keywords))
  (if (fboundp 'font-lock-flush)
      (font-lock-flush) (font-lock-fontify-buffer)))

;;;###autoload
(define-globalized-minor-mode markchars-global-mode markchars-mode
  (lambda () (markchars-mode 1))
  :group 'markchars)

(provide 'markchars)
;;; markchars.el ends here