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 (defgroup egg nil
  37   "Tamago Version 4")
  38
  39 (defcustom egg-mode-preference t
  40   "*Make Egg as modefull input method, if non-NIL."
  41   :group 'egg :type 'boolean)
  42
  43 (defvar egg-default-language)
  44
  45 (defvar egg-last-method-name)
  46 (make-variable-buffer-local 'egg-last-method-name)
  47 (put 'egg-last-method-name 'permanent-local t)
  48
  49 (defvar egg-current-keymap nil)
  50 (make-variable-buffer-local 'egg-current-keymap)
  51 (put 'egg-current-keymap 'permanent-local t)
  52
  53 ;;;###autoload
  54 (defun egg-mode (&rest arg)
  55   "Toggle EGG  mode.
  56 \\[describe-bindings]
  57 "
  58   (interactive "P")
  59   (if (null arg)
  60       ;; Turn off
  61       (unwind-protect
  62           (progn
  63             (its-exit-mode)
  64             (egg-exit-conversion))
  65         (setq describe-current-input-method-function nil)
  66         (if (eq (current-local-map) egg-current-keymap)
  67             (use-local-map (keymap-parent (current-local-map))))
  68         (remove-hook 'input-method-activate-hook 'its-set-mode-line-title t)
  69         (force-mode-line-update))
  70     ;; Turn on
  71     (if (null (string= (car arg) egg-last-method-name))
  72         (progn
  73           (funcall (nth 1 arg))
  74           (setq egg-default-language its-current-language)))
  75     (egg-set-conversion-backend (nthcdr 2 arg))
  76     (egg-set-conversion-backend
  77      (list (assq its-current-language (nthcdr 2 arg))) t)
  78     (setq egg-last-method-name (car arg))
  79     (setq egg-current-keymap (if egg-mode-preference
  80                                  (egg-modefull-map)
  81                                (egg-modeless-map)))
  82     (use-local-map egg-current-keymap)
  83     (setq inactivate-current-input-method-function 'egg-mode)
  84     (setq describe-current-input-method-function 'egg-help)
  85     (make-local-hook 'input-method-activate-hook)
  86     (add-hook 'input-method-activate-hook 'its-set-mode-line-title nil t)
  87     (if (eq (selected-window) (minibuffer-window))
  88         (add-hook 'minibuffer-exit-hook 'egg-exit-from-minibuffer))
  89     (run-hooks 'egg-mode-hook)))
  90
  91 (defun egg-exit-from-minibuffer ()
  92   (inactivate-input-method)
  93   (if (<= (minibuffer-depth) 1)
  94       (remove-hook 'minibuffer-exit-hook 'egg-exit-from-minibuffer)))
  95
  96 (defun egg-modefull-map ()
  97   "Generate modefull keymap for EGG mode."
  98   (let ((map (make-sparse-keymap))
  99         (i 33))
 100     (define-key map "\C-_" 'egg-jis-code-input)
 101     (while (< i 127)
 102       (define-key map (vector i) 'egg-self-insert-char)
 103       (setq i (1+ i)))
 104     (its-define-select-keys map)
 105     (set-keymap-parent map (current-local-map))
 106     map))
 107
 108 (defun egg-modeless-map ()
 109   "Generate modeless keymap for EGG mode."
 110   (let ((map (make-sparse-keymap)))
 111     (define-key map " " 'mlh-space-bar-backward-henkan)
 112     (define-key map "\C-_" 'egg-jis-code-input)
 113     (set-keymap-parent map (current-local-map))
 114     map))
 115
 116 (defvar egg-context nil)
 117
 118 (defun egg-self-insert-char ()
 119   (interactive)
 120   (its-start last-command-char (and (eq last-command 'egg-use-context)
 121                                     egg-context)))
 122 \f
 123 (defvar egg-mark-list nil)
 124 (defvar egg-suppress-marking nil)
 125
 126 (defun egg-set-face (beg eng face &optional object)
 127   (put face 'face face)
 128   (add-text-properties beg eng
 129                        (list 'category face
 130                              'egg-face t
 131                              'modification-hooks '(egg-mark-modification))
 132                        object))
 133
 134 (defun egg-mark-modification (beg end)
 135   (if (and (null egg-suppress-marking)
 136            (or (get-text-property beg 'egg-face)
 137                (setq beg (next-single-property-change beg 'egg-face)))
 138            (or (get-text-property (1- end) 'egg-face)
 139                (setq end (previous-single-property-change end 'egg-face)))
 140            (< beg end))
 141       (let ((list egg-mark-list)
 142             (found 0)
 143             pair mb me b e)
 144         (add-hook 'post-command-hook 'egg-redraw-face t)
 145         (setq list egg-mark-list)
 146         (while (and list (< found 2))
 147           (setq pair (car list)
 148                 list (cdr list)
 149                 mb (car pair)
 150                 me (cdr pair)
 151                 b (marker-position mb)
 152                 e (marker-position me))
 153           (cond
 154            ;; no overwrapping -- SKIP
 155            ((or (null (eq (marker-buffer mb) (current-buffer)))
 156                 (or (> beg e) (< end b))))
 157            ;; completely included
 158            ((and (>= beg b) (<= end e))
 159             (setq found 3))
 160            ;; partially overwrapping
 161            (t
 162             (set-marker mb nil)
 163             (set-marker me nil)
 164             (setq egg-mark-list (delete pair egg-mark-list)
 165                   beg (min beg b)
 166                   end (max end e)
 167                   found (1+ found)))))
 168         (if (< found 3)
 169             (progn
 170               (setq b (make-marker)
 171                     e (make-marker)
 172                     egg-mark-list (cons (cons b e) egg-mark-list))
 173               (set-marker b beg)
 174               (set-marker e end))))))
 175
 176 (defun egg-redraw-face ()
 177   (let ((inhibit-read-only t)
 178         (inhibit-point-motion-hooks t)
 179         (egg-suppress-marking t)
 180         (list egg-mark-list)
 181         (org-buffer (current-buffer))
 182         (org-point (point))
 183         mb me b e p)
 184     (setq egg-mark-list nil)
 185     (remove-hook 'post-command-hook 'egg-redraw-face)
 186     (while list
 187       (setq mb (car (car list))
 188             me (cdr (car list))
 189             list (cdr list))
 190       (when (marker-buffer mb)
 191         (set-buffer (marker-buffer mb))
 192         (let ((before-change-functions nil) (after-change-functions nil))
 193           (save-restriction
 194             (widen)
 195             (setq b (max mb (point-min))
 196                   e (min me (point-max)))
 197             (set-marker mb nil)
 198             (set-marker me nil)
 199             (while (< b e)
 200               (if (null (get-text-property b 'egg-face))
 201                   (setq b (next-single-property-change b 'egg-face nil e)))
 202               (setq p (next-single-property-change b 'egg-face nil e))
 203               (when (< b p)
 204                 (goto-char b)
 205                 (setq str (buffer-substring b p))
 206                 (delete-region b p)
 207                 (remove-text-properties 0 (- p b) '(face) str)
 208                 (insert str)
 209                 (setq b p)))))))
 210     (set-buffer org-buffer)
 211     (goto-char org-point)))
 212 \f
 213 (defvar egg-messages nil)
 214 (defvar egg-message-language-alist nil)
 215
 216 (defun egg-get-message (message)
 217   (let ((lang (or (cdr (assq egg-default-language egg-message-language-alist))
 218                   egg-default-language)))
 219     (or (nth 1 (assq message (cdr (assq lang egg-messages))))
 220         (nth 1 (assq message (cdr (assq nil egg-messages))))
 221         (error "EGG internal error: no such message: %s (%s)"
 222                message egg-default-language))))
 223
 224 (defun egg-add-message (list)
 225   (let (l msg-l)
 226     (while list
 227       (setq l (car list))
 228       (or (setq msg-l (assq (car l) egg-messages))
 229           (setq egg-messages (cons (list (car l)) egg-messages)
 230                 msg-l (car egg-messages)))
 231       (mapcar
 232        (lambda (msg)
 233          (setcdr msg-l (cons msg (delq (assq (car msg) msg-l) (cdr msg-l)))))
 234        (cdr l))
 235       (setq list (cdr list)))))
 236
 237 (defun egg-set-message-language-alist (alist)
 238   (let ((a alist))
 239     (while a
 240       (setq egg-message-language-alist
 241             (delq (assq (caar a) egg-message-language-alist)
 242                   egg-message-language-alist))
 243       (setq a (cdr a)))
 244     (setq egg-message-language-alist
 245           (append alist egg-message-language-alist))))
 246
 247 (put 'egg-error 'error-conditions '(error egg-error))
 248 (put 'egg-error 'error-message "EGG error")
 249
 250 (defun egg-error (message &rest args)
 251   (if (symbolp message)
 252       (setq message (egg-get-message message)))
 253   (signal 'egg-error (list (apply 'format message args))))
 254 \f
 255 ;;;
 256 ;;; auto fill controll
 257 ;;;
 258
 259 (defun egg-do-auto-fill ()
 260   (if (and auto-fill-function (> (current-column) fill-column))
 261       (let ((ocolumn (current-column)))
 262         (funcall auto-fill-function)
 263         (while (and (< fill-column (current-column))
 264                     (< (current-column) ocolumn))
 265           (setq ocolumn (current-column))
 266           (funcall auto-fill-function)))))
 267
 268 (eval-when (eval load)
 269   (require 'its)
 270   (require 'menudiag)
 271   (require 'egg-mlh)
 272   (require 'egg-cnv)
 273   (require 'egg-com))
 274
 275 (add-hook 'kill-emacs-hook 'egg-kill-emacs-function)
 276 (defun egg-kill-emacs-function ()
 277   (egg-finalize-backend))
 278
 279 (provide 'egg)
 280
 281 ;;; egg.el ends here