code.delx.au - gnu-emacs/blob - lisp/character-fold.el

   1 ;;; character-fold.el --- match unicode to similar ASCII -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2015 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: emacs-devel@gnu.org
   6 ;; Keywords: matching
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Code:
  24
  25 \f
  26 ;;;###autoload
  27 (defvar character-fold-search t
  28   "Non-nil if searches should fold similar characters.
  29 This means some characters will match entire groups of characters.
  30 For instance, \" will match all variants of double quotes, and
  31 the letter a will match all of its accented versions (and then
  32 some).")
  33
  34 (defconst character-fold-table
  35   (eval-when-compile
  36     (let* ((equiv (make-char-table 'character-fold-table))
  37            (table (unicode-property-table-internal 'decomposition))
  38            (func (char-table-extra-slot table 1)))
  39       ;; Ensure the table is populated.
  40       (map-char-table
  41        (lambda (i v) (when (consp i) (funcall func (car i) v table)))
  42        table)
  43
  44       ;; Compile a list of all complex characters that each simple
  45       ;; character should match.
  46       (map-char-table
  47        (lambda (i dec)
  48          (when (consp dec)
  49            ;; Discard a possible formatting tag.
  50            (when (symbolp (car dec))
  51              (setq dec (cdr dec)))
  52            ;; Skip trivial cases like ?a decomposing to (?a).
  53            (unless (or (and (eq i (car dec))
  54                             (not  (cdr dec))))
  55              (let ((d dec) k found multiletter)
  56                (while (and d (not found))
  57                  (setq k (pop d))
  58                  ;; Is k a number or letter, per unicode standard?
  59                  (setq found (memq (get-char-code-property k 'general-category)
  60                                    '(Lu Ll Lt Lm Lo Nd Nl No))))
  61                (if found
  62                    ;; Check if the decomposition has more than one letter,
  63                    ;; because then we don't want the first letter to match
  64                    ;; the decomposition.
  65                    (dolist (k d)
  66                      (when (memq (get-char-code-property k 'general-category)
  67                                  '(Lu Ll Lt Lm Lo Nd Nl No))
  68                        (setq multiletter t)))
  69                  ;; If there's no number or letter on the
  70                  ;; decomposition, take the first character in it.
  71                  (setq found (car-safe dec)))
  72                ;; Add i to the list of characters that k can
  73                ;; represent. Also possibly add its decomposition, so we can
  74                ;; match multi-char representations like (format "a%c" 769)
  75                (when (and found (not (eq i k)))
  76                  (let ((chars (cons (char-to-string i) (aref equiv k))))
  77                    (aset equiv k
  78                          (if multiletter chars
  79                            (cons (apply #'string dec) chars)))))))))
  80        table)
  81
  82       ;; Add some manual entries.
  83       (dolist (it '((?\" "＂" "“" "”" "”" "„" "⹂" "〞" "‟" "‟" "❞" "❝" "❠" "“" "„" "〝" "〟" "🙷" "🙶" "🙸" "«" "»")
  84                     (?' "❟" "❛" "❜" "‘" "’" "‚" "‛" "‚" "󠀢" "❮" "❯" "‹" "›")
  85                     (?` "❛" "‘" "‛" "󠀢" "❮" "‹")
  86                     (?\s "\t" "\r" "\n")))
  87         (let ((idx (car it))
  88               (chars (cdr it)))
  89           (aset equiv idx (append chars (aref equiv idx)))))
  90
  91       ;; Convert the lists of characters we compiled into regexps.
  92       (map-char-table
  93        (lambda (i v) (let ((re (regexp-opt (cons (char-to-string i) v))))
  94                   (if (consp i)
  95                       (set-char-table-range equiv i re)
  96                     (aset equiv i re))))
  97        equiv)
  98       equiv))
  99   "Used for folding characters of the same group during search.")
 100
 101 ;;;###autoload
 102 (defun character-fold-to-regexp (string &optional lax)
 103   "Return a regexp matching anything that character-folds into STRING.
 104 If `character-fold-search' is nil, `regexp-quote' string.
 105 Otherwise, any character in STRING that has an entry in
 106 `character-fold-table' is replaced with that entry (which is a
 107 regexp) and other characters are `regexp-quote'd.
 108 If LAX is non-nil, any single whitespace character is allowed to
 109 match any number of times."
 110   (if character-fold-search
 111       (apply #'concat
 112         (mapcar (lambda (c) (let ((out (or (aref character-fold-table c)
 113                                       (regexp-quote (string c)))))
 114                          (if (and lax (memq c '(?\s ?\t ?\r ?\n )))
 115                              (concat out "+")
 116                            out)))
 117                 string))
 118     (regexp-quote string)))
 119
 120 ;;; character-fold.el ends here