Move some of the heavier, rarely used Capfs to separate files

1 files changed, 138 insertions, 0 deletions

diff --git a/cape-char.el b/cape-char.el
new file mode 100644
index 0000000..4eb65fa
--- /dev/null
+++ b/cape-char.el
@@ -0,0 +1,138 @@
+;;; cape-char.el --- Character completion functions -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021, 2022  Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; 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 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides the `cape-tex', `cape-sgml' and `cape-rfc1345'
+;; completion functions.
+
+;;; Code:
+
+(require 'cape)
+
+;; Declare as pure function which is evaluated at compile time. We don't use a
+;; macro for this computation since packages like `helpful' will
+;; `macroexpand-all' the expensive `cape-char--define' macro calls.
+(eval-when-compile
+  (defun cape-char--translation (method regexp)
+    "Return character translation hash for METHOD.
+REGEXP is the regular expression matching the names."
+    (declare (pure t))
+    (save-window-excursion
+      (describe-input-method method)
+      (with-current-buffer "*Help*"
+        (let ((lines
+               (split-string
+                (replace-regexp-in-string
+                 "\n\n\\(\n\\|.\\)*" ""
+                 (replace-regexp-in-string
+                  "\\`\\(\n\\|.\\)*?----\n" ""
+                  (replace-regexp-in-string
+                   "\\`\\(\n\\|.\\)*?KEY SEQUENCE\n-+\n" ""
+                   (buffer-string))))
+                "\n"))
+              (hash (make-hash-table :test #'equal)))
+          (dolist (line lines)
+            (let ((beg 0) (len (length line)))
+              (while (< beg len)
+                (let* ((ename (next-single-property-change beg 'face line len))
+                       (echar (next-single-property-change ename 'face line len)))
+                  (when (and (get-text-property beg 'face line) (< ename len) (<= echar len))
+                    (let ((name (string-trim (substring-no-properties line beg ename)))
+                          (char (string-trim (substring-no-properties line ename echar))))
+                      (when (and (string-match-p regexp name) (= (length char) 1))
+                        (puthash name (aref char 0) hash))))
+                  (setq beg echar)))))
+          (kill-buffer)
+          hash)))))
+
+(defmacro cape-char--define (name method &rest prefix)
+  "Define character translation capf.
+NAME is the name of the capf.
+METHOD is the input method.
+PREFIX are the prefix characters."
+  (let ((capf (intern (format "cape-%s" name)))
+        (prefix-required (intern (format "cape-%s-prefix-required" name)))
+        (hash (intern (format "cape--%s-hash" name)))
+        (ann (intern (format "cape--%s-annotation" name)))
+        (docsig (intern (format "cape--%s-docsig" name)))
+        (exit (intern (format "cape--%s-exit" name)))
+        (properties (intern (format "cape--%s-properties" name))))
+    `(progn
+       (defvar ,hash (cape-char--translation
+                      ,method
+                      ,(concat "\\`" (regexp-opt (mapcar #'char-to-string prefix)))))
+       (defcustom ,prefix-required t
+         ,(format "Initial prefix is required for `%s' to trigger." capf)
+         :type 'boolean
+         :group 'cape)
+       (defun ,ann (name)
+         (when-let (char (gethash name ,hash))
+           (format " %c" char)))
+       (defun ,docsig (name)
+         (when-let (char (gethash name ,hash))
+           (format "%s (%s)"
+                   (get-char-code-property char 'name)
+                   (char-code-property-description
+                    'general-category
+                    (get-char-code-property char 'general-category)))))
+       (defun ,exit (name status)
+         (unless (eq status 'exact)
+           (when-let (char (gethash name ,hash))
+             (delete-region (max (point-min) (- (point) (length name))) (point))
+             (insert (char-to-string char)))))
+       (defvar ,properties
+         (list :annotation-function #',ann
+               :company-docsig #',docsig
+               :exit-function #',exit
+               :company-kind (lambda (_) 'text))
+         ,(format "Completion extra properties for `%s'." name))
+       (defun ,capf (&optional interactive)
+         ,(format "Complete unicode character at point.
+Uses the same input format as the %s input method,
+see (describe-input-method %S). If INTERACTIVE
+is nil the function acts like a capf." method method)
+         (interactive (list t))
+         (if interactive
+             ;; NOTE: Disable cycling since replacement breaks it.
+             (let (completion-cycle-threshold ,prefix-required)
+               (when (memq last-input-event ',prefix)
+                 (self-insert-command 1 last-input-event))
+               (cape--interactive #',capf))
+           (when-let (bounds
+                      (cond
+                       ((thing-at-point-looking-at
+                         ,(concat (regexp-opt (mapcar #'char-to-string prefix)) "[^ \n\t]*" ))
+                        (cons (match-beginning 0) (match-end 0)))
+                       ((not ,prefix-required) (cons (point) (point)))))
+             (append
+              (list (car bounds) (cdr bounds)
+                    (cape--table-with-properties ,hash :category ',capf)
+                    :exclusive 'no)
+              ,properties)))))))
+
+;;;###autoload (autoload 'cape-tex "cape-char" nil t)
+;;;###autoload (autoload 'cape-sgml "cape-char" nil t)
+;;;###autoload (autoload 'cape-rfc1345 "cape-char" nil t)
+(cape-char--define tex "TeX" ?\\ ?^ ?_)
+(cape-char--define sgml "sgml" ?&)
+(cape-char--define rfc1345 "rfc1345" ?&)
+
+(provide 'cape-char)
+;;; cape-char.el ends here