egg.el

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