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