cgit.sxemacs.org Git - riece/blob - lisp/riece-mcat.el

   1 (defvar riece-mcat-alist
   2   '(("Japanese" . riece-mcat-japanese)))
   3
   4 (defun riece-mcat (string)
   5   (let ((entry (assoc current-language-environment riece-mcat-alist)))
   6     (when entry
   7       (require (cdr entry))
   8       (or (cdr (assoc string (symbol-value (intern
   9                                             (concat (symbol-name (cdr entry))
  10                                                     "-alist")))))
  11           string))))
  12
  13 (defun riece-mcat-extract-from-form (form)
  14   (if (and form (listp form) (listp (cdr form)))
  15       (if (eq (car form) 'riece-mcat)
  16           (cdr form)
  17         (delq nil (apply #'nconc
  18                          (mapcar #'riece-mcat-extract-from-form form))))))
  19
  20 (defun riece-mcat-extract (files alist)
  21   (save-excursion
  22     (let (message-list)
  23       (while files
  24         (with-temp-buffer
  25           (insert-file-contents (car files))
  26           (goto-char (point-min))
  27           (while (progn
  28                    (while (progn (skip-chars-forward " \t\n\f")
  29                                  (looking-at ";"))
  30                      (forward-line 1))
  31                    (not (eobp)))
  32             (setq message-list
  33                   (nconc message-list
  34                          (riece-mcat-extract-from-form
  35                           (read (current-buffer)))))))
  36         (setq files (cdr files)))
  37       (setq message-list (sort message-list #'string-lessp))
  38       (while message-list
  39         (if (equal (car message-list)
  40                    (nth 1 message-list))
  41             (setq message-list (nthcdr 2 message-list))
  42           (unless (assoc (car message-list) alist)
  43             (setq alist (cons (list (car message-list)) alist)))
  44           (setq message-list (cdr message-list))))
  45       alist)))
  46
  47 (defun riece-mcat-update (files mcat-file mcat-alist)
  48   (let (alist)
  49     (save-excursion
  50       (set-buffer (find-file-noselect mcat-file))
  51       (goto-char (point-min))
  52       (re-search-forward (concat "^\\s-*(\\(defvar\\|defconst\\)\\s-+"
  53                                  (regexp-quote (symbol-name mcat-alist))))
  54       (goto-char (match-beginning 0))
  55       (save-excursion
  56         (eval (read (current-buffer))))
  57       (setq alist (riece-mcat-extract files (symbol-value mcat-alist)))
  58       (delete-region (point) (progn (forward-sexp) (point)))
  59       (insert "(defconst " (symbol-name mcat-alist) "\n  '(")
  60       (while alist
  61         (insert "(" (prin1-to-string (car (car alist))) " . "
  62                 (prin1-to-string (cdr (car alist))) ")")
  63         (if (cdr alist)
  64             (insert "\n   "))
  65         (setq alist (cdr alist)))
  66       (insert "))")
  67       (save-buffer))))
  68
  69 (provide 'riece-mcat)