lisp/character-fold.el

   1 ;;; chracter-fold.el --- matching unicode characters to their ascii similars -*- 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 charactes.
  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       ;; Compile a list of all complex characters that each simple
  38       ;; character should match.
  39       (map-char-table
  40        (lambda (i dec)
  41          (when (consp dec)
  42            ;; Discard a possible formatting tag.
  43            (when (symbolp (car dec))
  44              (setq dec (cdr dec)))
  45            ;; Skip trivial cases lika ?a decomposing to (?a).
  46            (unless (or (and (eq i (car dec))
  47                             (not  (cdr dec))))
  48              (let ((d dec) k found multiletter)
  49                (while (and d (not found))
  50                  (setq k (pop d))
  51                  ;; Is k a number or letter, per unicode standard?
  52                  (setq found (memq (get-char-code-property k 'general-category)
  53                                    '(Lu Ll Lt Lm Lo Nd Nl No))))
  54                (if found
  55                    ;; Check if the decomposition has more than one letter,
  56                    ;; because then we don't want the first letter to match
  57                    ;; the decomposition.
  58                    (dolist (k d)
  59                      (when (memq (get-char-code-property k 'general-category)
  60                                  '(Lu Ll Lt Lm Lo Nd Nl No))
  61                        (setq multiletter t)))
  62                  ;; If there's no number or letter on the
  63                  ;; decomposition, take the first character in it.
  64                  (setq found (car-safe dec)))
  65                ;; Add i to the list of characters that k can
  66                ;; represent. Also possibly add its decomposition, so we can
  67                ;; match multi-char representations like (format "a%c" 769)
  68                (when (and found (not (eq i k)))
  69                  (let ((chars (cons (char-to-string i) (aref equiv k))))
  70                    (aset equiv k
  71                          (if multiletter chars
  72                            (cons (apply #'string dec) chars)))))))))
  73        (unicode-property-table-internal 'decomposition))
  74       (dolist (it '((?\" "＂" "“" "”" "”" "„" "⹂" "〞" "‟" "‟" "❞" "❝" "❠" "“" "„" "〝" "〟" "🙷" "🙶" "🙸" "«" "»")
  75                     (?' "❟" "❛" "❜" "‘" "’" "‚" "‛" "‚" "󠀢" "❮" "❯" "‹" "›")
  76                     (?` "❛" "‘" "‛" "󠀢" "❮" "‹")
  77                     (?\s "\t" "\r" "\n")))
  78         (let ((idx (car it))
  79               (chars (cdr it)))
  80           (aset equiv idx (append chars (aref equiv idx)))))
  81       (map-char-table
  82        (lambda (i v) (let ((re (regexp-opt (cons (char-to-string i) v))))
  83                   (if (consp i)
  84                       (set-char-table-range equiv i re)
  85                     (aset equiv i re))))
  86        equiv)
  87       equiv))
  88   "Used for folding characters of the same group during search.")
  89
  90 ;;;###autoload
  91 (defun character-fold-to-regexp (string &optional lax)
  92   "Return a regexp matching anything that character-folds into STRING.
  93 If `character-fold-search' is nil, `regexp-quote' string.
  94 Otherwise, any character in STRING that has an entry in
  95 `character-fold-table' is replaced with that entry (which is a
  96 regexp) and other characters are `regexp-quote'd.
  97 If LAX is non-nil, any single whitespace character is allowed to
  98 match any number of times."
  99   (if character-fold-search
 100       (apply #'concat
 101         (mapcar (lambda (c) (let ((out (or (aref character-fold-table c)
 102                                       (regexp-quote (string c)))))
 103                          (if (and lax (memq c '(?\s ?\t ?\r ?\n )))
 104                              (concat out "+")
 105                            out)))
 106                 string))
 107     (regexp-quote string)))
 108
 109 ;;; chracter-fold.el ends here