;;; markchars.el --- Mark chars fitting certain characteristics

;; Copyright (C) 2011-2020  Free Software Foundation, Inc.

;; Author: Lennart Borgman <lennart.borgman@gmail.com>
;; Contributhor: Ted Zlatanov <tzz@lifelogs.com>
;; Created: 2010-03-22 Mon
;; Version: 0.2.2
;; 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.
;;
;; You can set `nobreak-char-display' to nil, and use
;; `markchars-nobreak-space' and `markchars-nobreak-hyphen'
;; in Dired buffers to highlight `nobreak-space' and `nobreak-hyphen'
;; only in file names, not `nobreak-space' used by thousands separators
;; in file sizes (bug#44236).
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; 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)

(defface markchars-nobreak-space
  '((t :inherit nobreak-space))
  "Face for displaying nobreak space."
  :group 'markchars)

(defface markchars-nobreak-hyphen
  '((t :inherit nobreak-hyphen))
  "Face for displaying nobreak hyphens."
  :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)

(defvar markchars-nobreak-space-pattern
  (rx (any ;; ?\N{SPACE}
           ?\N{NO-BREAK SPACE}
           ?\N{OGHAM SPACE MARK}
           ?\N{EN QUAD}
           ?\N{EM QUAD}
           ?\N{EN SPACE}
           ?\N{EM SPACE}
           ?\N{THREE-PER-EM SPACE}
           ?\N{FOUR-PER-EM SPACE}
           ?\N{SIX-PER-EM SPACE}
           ?\N{FIGURE SPACE}
           ?\N{PUNCTUATION SPACE}
           ?\N{THIN SPACE}
           ?\N{HAIR SPACE}
           ?\N{NARROW NO-BREAK SPACE}
           ?\N{MEDIUM MATHEMATICAL SPACE}
           ?\N{IDEOGRAPHIC SPACE}))
  "A list of characters with general-category `Zs' (Separator, Space).")

(defvar markchars-nobreak-hyphen-pattern
  (rx (any ?\N{SOFT HYPHEN} ?\N{HYPHEN} ?\N{NON-BREAKING HYPHEN}))
  "A list of hyphen characters.")

(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-ASCII space chars"
                                markchars-nobreak-space)
                         (const :tag "Non-ASCII hyphen chars"
                                markchars-nobreak-hyphen)
                         (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-nobreak-space)
                             (list
                              markchars-nobreak-space-pattern
                              (list 0 '(markchars--render-nobreak-space
                                        (match-beginning 0)
                                        (match-end 0)))))
                            ((eq what 'markchars-nobreak-hyphen)
                             (list
                              markchars-nobreak-hyphen-pattern
                              (list 0 '(markchars--render-nobreak-hyphen
                                        (match-beginning 0)
                                        (match-end 0)))))
                            ((eq what 'markchars-nonidn-fun)
                             (list
                              "\\<\\w+\\>"
                              (list 0 '(markchars--render-nonidn
                                        (match-beginning 0)
                                        (match-end 0)))))
                            ((eq what 'markchars-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))
         ;; Strip combining characters (bug#36923)
         (text (mapconcat (lambda (c)
                            (when (zerop (get-char-code-property
                                          c 'canonical-combining-class))
                              (string c)))
                          (string-to-list text) ""))
         (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))))

(defun markchars--render-nobreak-space (beg end)
  "Assign markchars pattern properties between BEG and END.
In Dired/WDired buffers, highlight nobreak-space characters
only in file names, not anywhere else, so it doesn't highlight
nobreak-space characters used by thousands separators in file sizes."
  (when (or (not (derived-mode-p 'dired-mode 'wdired-mode))
            (or (get-text-property beg 'dired-filename)
                (get-text-property end 'dired-filename)))
    (put-text-property beg end 'face 'markchars-nobreak-space)
    (put-text-property beg end 'markchars 'nobreak-space)))

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

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