egg.el

   1 ;;; egg.el --- EGG Input Method Architecture
   2
   3 ;; Copyright (C) 1999-2015 Free Software Foundation, Inc
   4 ;;               2014, 2015 Mitsutoshi NAKANO <bkbin005@rinku.zaq.ne.jp>
   5 ;;               2015 Hiroki Sato <hrs@allbsd.org>
   6
   7 ;; Author: NIIBE Yutaka <gniibe@chroot.org>
   8 ;;         KATAYAMA Yoshio <kate@pfu.co.jp>
   9
  10 ;; Keywords: mule, multilingual, input method
  11
  12 ;; This file is part of EGG.
  13
  14 ;; EGG is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; EGG is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc.,
  27 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  28
  29 ;;; Commentary:
  30
  31 ;;; Code:
  32
  33 (defconst egg-version "5.0.7.1"
  34   "Version number for this version of Tamago.")
  35
  36 (defconst egg-tsunagi-version egg-version
  37   "Version number for this version of Tamago-tsunagi.")
  38
  39 (eval-when-compile
  40   (require 'cl))
  41
  42 (require 'egg-edep)
  43
  44 (autoload 'egg-simple-input-method "egg-sim"
  45   "simple input method for Tamago-tsunagi." t)
  46
  47 (defgroup egg nil
  48   "Tamago Version 5.")
  49
  50 (defcustom egg-mode-preference t
  51   "*Make Egg as modefull input method, if non-NIL."
  52   :group 'egg :type 'boolean)
  53
  54 (defvar egg-default-language)
  55
  56 (defvar egg-last-method-name nil)
  57 (make-variable-buffer-local 'egg-last-method-name)
  58 (put 'egg-last-method-name 'permanent-local t)
  59
  60 (defvar egg-mode-map-alist nil)
  61 (defvar egg-sub-mode-map-alist nil)
  62
  63 (defmacro define-egg-mode-map (mode &rest initializer)
  64   (let ((map (intern (concat "egg-" (symbol-name mode) "-map")))
  65         (var (intern (concat "egg-" (symbol-name mode) "-mode")))
  66         (comment (concat (symbol-name mode) " keymap for EGG mode.")))
  67     `(progn
  68        (defvar ,map (let ((map (make-sparse-keymap)))
  69                       ,@initializer
  70                       map)
  71          ,comment)
  72        (fset ',map ,map)
  73        (defvar ,var nil)
  74        (make-variable-buffer-local ',var)
  75        (put ',var 'permanent-local t)
  76        (or (assq ',var egg-mode-map-alist)
  77            (setq egg-mode-map-alist (append egg-mode-map-alist
  78                                             '((,var . ,map))))))))
  79
  80 (define-egg-mode-map modefull
  81   (define-key map "\C-^" 'egg-simple-input-method)
  82   (let ((i 33))
  83     (while (< i 127)
  84       (define-key map (vector i) 'egg-self-insert-char)
  85       (setq i (1+ i)))))
  86
  87 (define-egg-mode-map modeless
  88   (define-key map " " 'mlh-space-bar-backward-henkan)
  89   (define-key map "\C-^" 'egg-simple-input-method))
  90
  91 (defvar egg-enter/leave-fence-hook nil)
  92
  93 (defun egg-enter/leave-fence (&optional old new)
  94   (run-hooks 'egg-enter/leave-fence-hook))
  95
  96 (defvar egg-activated nil)
  97 (make-variable-buffer-local 'egg-activated)
  98 (put 'egg-activated 'permanent-local t)
  99
 100 (defun egg-activate-keymap ()
 101   (when (and egg-activated
 102              (null (eq (car egg-sub-mode-map-alist)
 103                        (car minor-mode-overriding-map-alist))))
 104     (let ((alist (append egg-sub-mode-map-alist egg-mode-map-alist))
 105           (overriding (copy-sequence minor-mode-overriding-map-alist)))
 106       (while alist
 107         (setq overriding (delq (assq (caar alist) overriding) overriding)
 108               alist (cdr alist)))
 109       (setq minor-mode-overriding-map-alist (append egg-sub-mode-map-alist
 110                                                     overriding
 111                                                     egg-mode-map-alist)))))
 112
 113 (add-hook 'egg-enter/leave-fence-hook 'egg-activate-keymap t)
 114
 115 (defun egg-modify-fence (&rest arg)
 116   (add-hook 'post-command-hook 'egg-post-command-func))
 117
 118 (defun egg-post-command-func ()
 119   (run-hooks 'egg-enter/leave-fence-hook)
 120   (remove-hook 'post-command-hook 'egg-post-command-func))
 121
 122 (defvar egg-change-major-mode-buffer nil)
 123
 124 (defun egg-activate-keymap-after-command ()
 125   (while egg-change-major-mode-buffer
 126     (let ((buf (car egg-change-major-mode-buffer)))
 127       (if (buffer-live-p buf)
 128           (with-current-buffer buf
 129             (egg-activate-keymap)))
 130       (setq egg-change-major-mode-buffer (cdr egg-change-major-mode-buffer))))
 131   (remove-hook 'post-command-hook 'egg-activate-keymap-after-command))
 132
 133 (defun egg-change-major-mode-func ()
 134   (setq egg-change-major-mode-buffer (cons (current-buffer)
 135                                            egg-change-major-mode-buffer))
 136   (add-hook 'post-command-hook 'egg-activate-keymap-after-command))
 137
 138 (add-hook 'change-major-mode-hook 'egg-change-major-mode-func)
 139
 140 ;;;###autoload
 141 (defun egg-mode (&rest arg)
 142   "Toggle EGG  mode.
 143 \\[describe-bindings]
 144 "
 145   (interactive "P")
 146   (if (null arg)
 147       ;; Turn off
 148       (unwind-protect
 149           (progn
 150             (its-exit-mode)
 151             (egg-exit-conversion))
 152         (setq describe-current-input-method-function nil
 153               egg-modefull-mode nil
 154               egg-modeless-mode nil)
 155         (remove-hook 'input-method-activate-hook 'its-set-mode-line-title t)
 156         (force-mode-line-update))
 157     ;; Turn on
 158     (if (null (string= (car arg) egg-last-method-name))
 159         (progn
 160           (funcall (nth 1 arg))
 161           (setq egg-default-language its-current-language)))
 162     (egg-set-conversion-backend (nthcdr 2 arg))
 163     (egg-set-conversion-backend
 164      (list (assq its-current-language (nthcdr 2 arg))) t)
 165     (setq egg-last-method-name (car arg)
 166           egg-activated t)
 167     (egg-activate-keymap)
 168     (if egg-mode-preference
 169         (progn
 170           (setq egg-modefull-mode t)
 171           (its-define-select-keys egg-modefull-map))
 172       (setq egg-modeless-mode t))
 173     (set (if (fboundp 'deactivate-current-input-method-function)
 174              'deactivate-current-input-method-function
 175            'inactivate-current-input-method-function)
 176          'egg-mode)
 177     (setq describe-current-input-method-function 'egg-help)
 178     (if (fboundp 'make-local-hook)
 179       (eval '(make-local-hook 'input-method-activate-hook)))
 180     (add-hook 'input-method-activate-hook 'its-set-mode-line-title nil t)
 181     (if (eq (selected-window) (minibuffer-window))
 182         (add-hook 'minibuffer-exit-hook 'egg-exit-from-minibuffer))
 183     (run-hooks 'egg-mode-hook)))
 184
 185 (defun egg-exit-from-minibuffer ()
 186   (if (fboundp 'deactivate-input-method)
 187       (deactivate-input-method)
 188     (inactivate-input-method))
 189   (if (<= (minibuffer-depth) 1)
 190       (remove-hook 'minibuffer-exit-hook 'egg-exit-from-minibuffer)))
 191
 192 (defvar egg-context nil)
 193
 194 (defun egg-self-insert-char ()
 195   (interactive)
 196   (its-start (if (boundp 'last-command-event)
 197                  last-command-event
 198                last-command-char)
 199              (and (eq last-command 'egg-use-context)
 200                                     egg-context)))
 201
 202 (defun egg-remove-all-text-properties (from to &optional object)
 203   (let ((p from)
 204         props prop)
 205     (while (< p to)
 206       (setq prop (text-properties-at p object))
 207       (while prop
 208         (unless (eq (car prop) 'composition)
 209           (setq props (plist-put props (car prop) nil)))
 210         (setq prop (cddr prop)))
 211       (setq p (next-property-change p object to)))
 212     (remove-text-properties from to props object)))
 213
 214 (defun egg-setup-invisibility-spec ()
 215   (if (listp buffer-invisibility-spec)
 216       (unless (condition-case nil (memq 'egg buffer-invisibility-spec) (error))
 217         (setq buffer-invisibility-spec (cons 'egg buffer-invisibility-spec)))
 218     (unless (eq buffer-invisibility-spec t)
 219       (setq buffer-invisibility-spec (list 'egg buffer-invisibility-spec)))))
 220 \f
 221 (defvar egg-mark-list nil)
 222 (defvar egg-suppress-marking nil)
 223
 224 (defun egg-set-face (beg eng face &optional object)
 225   (let ((hook (get-text-property beg 'modification-hooks object)))
 226     (put face 'face face)
 227     (add-text-properties beg eng
 228                          (list 'category face
 229                                'egg-face t
 230                                'modification-hooks (cons 'egg-mark-modification
 231                                                          hook))
 232                          object)))
 233
 234 (defun egg-mark-modification (beg end)
 235   (if (and (null egg-suppress-marking)
 236            (or (get-text-property beg 'egg-face)
 237                (setq beg (next-single-property-change beg 'egg-face)))
 238            (or (get-text-property (1- end) 'egg-face)
 239                (setq end (previous-single-property-change end 'egg-face)))
 240            (< beg end))
 241       (let ((list egg-mark-list)
 242             (found 0)
 243             pair mb me b e)
 244         (add-hook 'post-command-hook 'egg-redraw-face t)
 245         (setq list egg-mark-list)
 246         (while (and list (< found 2))
 247           (setq pair (car list)
 248                 list (cdr list)
 249                 mb (car pair)
 250                 me (cdr pair)
 251                 b (marker-position mb)
 252                 e (marker-position me))
 253           (cond
 254            ;; no overwrapping -- SKIP
 255            ((or (null (eq (marker-buffer mb) (current-buffer)))
 256                 (or (> beg e) (< end b))))
 257            ;; completely included
 258            ((and (>= beg b) (<= end e))
 259             (setq found 3))
 260            ;; partially overwrapping
 261            (t
 262             (set-marker mb nil)
 263             (set-marker me nil)
 264             (setq egg-mark-list (delete pair egg-mark-list)
 265                   beg (min beg b)
 266                   end (max end e)
 267                   found (1+ found)))))
 268         (if (< found 3)
 269             (progn
 270               (setq b (make-marker)
 271                     e (make-marker)
 272                     egg-mark-list (cons (cons b e) egg-mark-list))
 273               (set-marker b beg)
 274               (set-marker e end))))))
 275
 276 (defun egg-redraw-face ()
 277   (let ((inhibit-read-only t)
 278         (inhibit-point-motion-hooks t)
 279         (egg-suppress-marking t)
 280         (list egg-mark-list)
 281         (org-buffer (current-buffer))
 282         (org-point (point))
 283         mb me b e p)
 284     (setq egg-mark-list nil)
 285     (remove-hook 'post-command-hook 'egg-redraw-face)
 286     (while list
 287       (setq mb (car (car list))
 288             me (cdr (car list))
 289             list (cdr list))
 290       (when (marker-buffer mb)
 291         (set-buffer (marker-buffer mb))
 292         (let ((before-change-functions nil) (after-change-functions nil))
 293           (save-excursion
 294             (save-restriction
 295               (widen)
 296               (setq b (max mb (point-min))
 297                     e (min me (point-max)))
 298               (set-marker mb nil)
 299               (set-marker me nil)
 300               (while (< b e)
 301                 (if (null (get-text-property b 'egg-face))
 302                     (setq b (next-single-property-change b 'egg-face nil e)))
 303                 (setq p (next-single-property-change b 'egg-face nil e))
 304                 (when (< b p)
 305                   (goto-char b)
 306                   (remove-text-properties 0 (- p b) '(face))
 307                   (setq b p))))))))
 308     (set-buffer org-buffer)
 309     (goto-char org-point)))
 310 \f
 311 (defvar egg-messages nil)
 312 (defvar egg-message-language-alist nil)
 313
 314 (defun egg-get-message (message)
 315   (let ((lang (or (cdr (assq egg-default-language egg-message-language-alist))
 316                   egg-default-language)))
 317     (or (nth 1 (assq message (cdr (assq lang egg-messages))))
 318         (nth 1 (assq message (cdr (assq nil egg-messages))))
 319         (error "EGG internal error: no such message: %s (%s)"
 320                message egg-default-language))))
 321
 322 (defun egg-add-message (list)
 323   (let (l msg-l)
 324     (while list
 325       (setq l (car list))
 326       (or (setq msg-l (assq (car l) egg-messages))
 327           (setq egg-messages (cons (list (car l)) egg-messages)
 328                 msg-l (car egg-messages)))
 329       (mapcar
 330        (lambda (msg)
 331          (setcdr msg-l (cons msg (delq (assq (car msg) msg-l) (cdr msg-l)))))
 332        (cdr l))
 333       (setq list (cdr list)))))
 334
 335 (defun egg-set-message-language-alist (alist)
 336   (let ((a alist))
 337     (while a
 338       (setq egg-message-language-alist
 339             (delq (assq (caar a) egg-message-language-alist)
 340                   egg-message-language-alist))
 341       (setq a (cdr a)))
 342     (setq egg-message-language-alist
 343           (append alist egg-message-language-alist))))
 344
 345 (put 'egg-error 'error-conditions '(error egg-error))
 346 (put 'egg-error 'error-message "EGG error")
 347
 348 (defun egg-error (message &rest args)
 349   (if (symbolp message)
 350       (setq message (egg-get-message message)))
 351   (signal 'egg-error (list (apply 'format message args))))
 352 \f
 353 ;;;
 354 ;;; auto fill controll
 355 ;;;
 356
 357 (defun egg-do-auto-fill ()
 358   (if (and auto-fill-function (> (current-column) fill-column))
 359       (let ((ocolumn (current-column)))
 360         (funcall auto-fill-function)
 361         (while (and (< fill-column (current-column))
 362                     (< (current-column) ocolumn))
 363           (setq ocolumn (current-column))
 364           (funcall auto-fill-function)))))
 365
 366 (eval-when (eval load)
 367   (require 'its)
 368   (require 'menudiag)
 369   (require 'egg-mlh)
 370   (require 'egg-cnv)
 371   (require 'egg-com))
 372
 373 (add-hook 'kill-emacs-hook 'egg-kill-emacs-function)
 374 (defun egg-kill-emacs-function ()
 375   (egg-finalize-backend))
 376
 377 (provide 'egg)
 378
 379 ;;; egg.el ends here