#xyzzy にはないシンボルと ansify にあるシンボルに色をつけるためのキーワードファイルの生成

gistfile1.lisp

;;
;; xyzzy にはないシンボルと ansify にあるシンボルに色をつけるためのキーワードファイルの生成
;;
;; Usage:
;;   M-x update-keyword-file
;;


(require "ansify")
(require "xl-ppcre")
(require "xml-http-request")
(require "xy-reference")

(defvar *missing-symbols-url* "https://github.com/bowbow99/xyzzy.ansify/wiki/missing-symbols")

;; 色の指定方法
;; http://xyzzy.s53.xrea.com/reference/wiki.cgi?p=%A5%AD%A1%BC%A5%EF%A1%BC%A5%C9%A5%D5%A5%A1%A5%A4%A5%EB%A4%CE%BD%F1%A4%AD%CA%FD
;; 
(defvar *xyzzy-function-with-reference-color* nil)
(defvar *xyzzy-variable-with-reference-color* ";*2")
(defvar *xyzzy-symbol-without-reference-color* ";**c")
(defvar *xyzzy-ansify-symbol-color* ";**9")
(defvar *xyzzy-missing-symbol-color* ";**1")

(defun update-lisp-keyword ()
  (interactive)
  (xy-reference:2kwd)
  (with-set-buffer
    (let ((keyword-file (merge-pathnames "lisp" *etc-path*))
          (buf (get-buffer-create "*tmp*")))
      (unwind-protect
          (progn
            (set-buffer buf)
            (insert-file-contents keyword-file)
            (replace-keyword-color)
            (insert-ansify-keywords)
            (insert-missing-keywords)
            (write-file keyword-file))
        (delete-buffer buf)))))

(defun replace-keyword-color ()
  ;; 色の設定
  (when *xyzzy-function-with-reference-color*
    (scan-buffer "^[;]" :regexp t)
    (insert *xyzzy-function-with-reference-color* #\LFD))
  (when *xyzzy-variable-with-reference-color*
    (replace-buffer ";*2" *xyzzy-variable-with-reference-color*))
  (when *xyzzy-symbol-without-reference-color*
    (replace-buffer ";**1" *xyzzy-symbol-without-reference-color*)))

(defun insert-ansify-keywords ()
  (insert-symbols ";; ansify にあるシンボル"
                  *xyzzy-ansify-symbol-color*
                  (ansify-external-symbols)))

(defun insert-missing-keywords ()
  (insert-symbols ";; xyzzy にも ansify にもないシンボル"
                  *xyzzy-missing-symbol-color*
                  (let ((ansify-syms (ansify-external-symbols)))
                    (remove-if #'(lambda (sym)
                                   (member sym ansify-syms :test #'string=))
                               (missing-symbols)))))

(defun insert-symbols (comment color syms)
  (goto-char (point-max))
  (insert #\LFD)
  (insert comment #\LFD)
  (insert color #\LFD)
  (dolist (sym syms)
    (insert sym #\LFD)))

(defun missing-symbols ()
  (flet ((html-unescape (s)
           (let ((html-escape '(("<" . "&lt;")
                                (">" . "&gt;")
                                ("&" . "&amp;")
                                ("\"" . "&quot;"))))
             (ppcre:regex-replace-all "&(lt|gt|amp|quot);" s
                                      #'(lambda (m &rest ignore)
                                          (car (rassoc m html-escape :test #'string=)))
                                      :simple-calls t))))
    (let ((html (xhr:xhr-get *missing-symbols-url*
                             :key 'xhr:xhr-response-text))
          r)
      (ppcre:do-register-groups ((#'html-unescape sym))
          ("<li><code>(.+?)</code></li>" html r)
        (push sym r)))))

(defun ansify-external-symbols ()
  (let (r)
    (do-external-symbols (sym :ansify)
      (let ((name (symbol-name sym)))
        (unless (find-symbol name :lisp)
          (push name r))))
    r))