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