code.delx.au - gnu-emacs-elpa/blob - packages/markchars/markchars.el

   1 ;;; markchars.el --- Mark chars fitting certain characteristics
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Contributhor: Ted Zlatanov <tzz@lifelogs.com>
   5 ;; Created: 2010-03-22 Mon
   6 ;; Version: 0.2.0
   7 ;; Last-Updated: 2011-04-15
   8 ;; URL:
   9 ;; Keywords:
  10 ;; Compatibility:
  11 ;;
  12 ;; Features that can be used by this library:
  13 ;;
  14 ;;   `idn'.
  15 ;;
  16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17 ;;
  18 ;;; Commentary:
  19 ;;
  20 ;; Mark special chars, by default nonascii, non-IDN chars, in modes
  21 ;; where they may be confused with regular chars. See `markchars-mode'
  22 ;; and `markchars-what'.  There are two modes: confusable detection
  23 ;; (where we look for mixed scripts within a word, without using the
  24 ;; http://www.unicode.org/reports/tr39/ confusable tables) and pattern
  25 ;; detection (where any regular expressions can be matched).
  26 ;;
  27 ;; The marked text will have the 'markchars property set to either
  28 ;; 'confusable or 'pattern and the face set to either
  29 ;; `markchars-face-confusable' or `markchars-face-pattern'
  30 ;; respectively.
  31 ;;
  32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33 ;;
  34 ;;; Change log:
  35 ;;
  36 ;;
  37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38 ;;
  39 ;; This program is free software; you can redistribute it and/or
  40 ;; modify it under the terms of the GNU General Public License as
  41 ;; published by the Free Software Foundation; either version 3, or
  42 ;; (at your option) any later version.
  43 ;;
  44 ;; This program is distributed in the hope that it will be useful,
  45 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  46 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  47 ;; General Public License for more details.
  48 ;;
  49 ;; You should have received a copy of the GNU General Public License
  50 ;; along with this program; see the file COPYING.  If not, write to
  51 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  52 ;; Floor, Boston, MA 02110-1301, USA.
  53 ;;
  54 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55 ;;
  56 ;;; Code:
  57
  58 (require 'idn nil t)
  59
  60 ;;;###autoload
  61 (defgroup markchars nil
  62   "Customization group for `markchars-mode'."
  63   :group 'convenience)
  64
  65 (defface markchars-light
  66   '((t (:underline "light blue")))
  67   "Light face for `markchars-mode' char marking."
  68   :group 'markchars)
  69
  70 (defface markchars-heavy
  71   '((t (:underline "magenta")))
  72   "Heavy face for `markchars-mode' char marking."
  73   :group 'markchars)
  74
  75 (defface markchars-white
  76   '((t (:underline "white")))
  77   "White face for `markchars-mode' char marking."
  78   :group 'markchars)
  79
  80 (defcustom markchars-face-pattern 'markchars-heavy
  81   "Pointer to face used for marking matched patterns."
  82   :type 'face
  83   :group 'markchars)
  84
  85 (defcustom markchars-face-confusable 'markchars-light
  86   "Pointer to face used for marking confusables."
  87   :type 'face
  88   :group 'markchars)
  89
  90 (defcustom markchars-face-nonidn 'markchars-white
  91   "Pointer to face used for marking non-IDN characters."
  92   :type 'face
  93   :group 'markchars)
  94
  95 (defcustom markchars-simple-pattern "[[:nonascii:]]+"
  96   "Regexp for characters to mark, a simple pattern.
  97
  98 By default it matches nonascii-chars."
  99   :type 'regexp
 100   :group 'markchars)
 101
 102 (defcustom markchars-what
 103   `(markchars-simple-pattern
 104     markchars-confusables
 105     ,@(when (fboundp 'idn-is-recommended) '(markchars-nonidn-fun)))
 106   "Things to mark, a list of regular expressions or symbols."
 107   :type `(repeat (choice :tag "Marking choices"
 108                          (const
 109                           :tag "Non IDN chars (Unicode.org tr39 suggestions)"
 110                           markchars-nonidn-fun)
 111                          (const :tag "Confusables" markchars-confusables)
 112                          (const :tag "`markchars-simple-pattern'"
 113                                 markchars-simple-pattern)
 114                          (regexp :tag "Arbitrary pattern")))
 115   :group 'markchars)
 116
 117 (make-obsolete-variable 'markchars-keywords 'markchars-what "markchars.el 0.2")
 118
 119 (defvar markchars-used-keywords nil
 120   "Keywords for font lock.")
 121 (put 'markchars-used-keywords 'permanent-local t)
 122
 123 (defun markchars-set-keywords ()
 124   "Set `markchars-used-keywords' from options."
 125   (set (make-local-variable 'markchars-used-keywords)
 126        (delq nil (mapcar (lambda (what)
 127                            (when (eq what 'markchars-simple-pattern)
 128                              (setq what markchars-simple-pattern))
 129                            (cond
 130                             ((eq what 'markchars-nonidn-fun)
 131                              (list
 132                               "\\<\\w+\\>"
 133                               (list 0 '(markchars--render-nonidn
 134                                         (match-beginning 0)
 135                                         (match-end 0)))))
 136                             ((eq what 'confusables)
 137                              (list
 138                               "\\<\\w+\\>"
 139                               (list 0 '(markchars--render-confusables
 140                                         (match-beginning 0)
 141                                         (match-end 0)))))
 142                             ((stringp what)
 143                              (list
 144                               what
 145                               (list 0 '(markchars--render-pattern
 146                                         (match-beginning 0)
 147                                         (match-end 0)))))))
 148                          markchars-what))))
 149
 150 (defun markchars--render-pattern (beg end)
 151   "Assign markchars pattern properties between BEG and END."
 152   (put-text-property beg end 'face markchars-face-pattern)
 153   (put-text-property beg end 'markchars 'pattern))
 154
 155 (defun markchars--render-confusables (beg end)
 156   "Assign markchars confusable properties between BEG and END."
 157   (let* ((text (buffer-substring-no-properties beg end))
 158          (scripts (mapcar
 159                    (lambda (c) (aref char-script-table c))
 160                    (string-to-list text)))
 161          ;; `scripts-extra' is not nil is there was more than one script
 162          (scripts-extra (delq (car scripts) scripts)))
 163     (when scripts-extra
 164       (put-text-property beg end 'markchars 'confusable)
 165       (put-text-property beg end 'face markchars-face-confusable))))
 166
 167 (defun markchars--render-nonidn (beg end)
 168   "Assign markchars confusable properties between BEG and END."
 169   (save-excursion
 170     (goto-char beg)
 171     (while (<= (point) end)
 172       (let ((c (char-after)))
 173         (when (and (> c 256)
 174                    (not (idn-is-recommended c)))
 175           (put-text-property (point) (1+ (point)) 'markchars 'nonidn)
 176           (put-text-property (point) (1+ (point)) 'face markchars-face-nonidn)))
 177       (forward-char))))
 178
 179 ;;;###autoload
 180 (define-minor-mode markchars-mode
 181   "Mark special characters.
 182 Which characters to mark are defined by `markchars-pattern'.
 183
 184 The default is to mark nonascii chars with a magenta underline."
 185   :group 'markchars
 186   :lighter " Mchar"
 187   (if markchars-mode
 188       (progn
 189         (markchars-set-keywords)
 190         (let ((props (make-local-variable 'font-lock-extra-managed-props)))
 191           (add-to-list props 'markchars))
 192         (font-lock-add-keywords nil markchars-used-keywords))
 193     (font-lock-remove-keywords nil markchars-used-keywords))
 194   (if (fboundp 'font-lock-flush)
 195       (font-lock-flush) (font-lock-fontify-buffer)))
 196
 197 ;;;###autoload
 198 (define-globalized-minor-mode markchars-global-mode markchars-mode
 199   (lambda () (markchars-mode 1))
 200   :group 'markchars)
 201
 202 (provide 'markchars)
 203 ;;; markchars.el ends here