* riece-mcat.el (riece-mcat-update): New function.
[riece] / 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)