EmacsのDoctorの操作感を改善する
しむどん
：
2025-06-21
Emacsにはユーザーの心をケアするための doctor.el という機能が同梱されている。もしも作業中に心が疲れてしまったら M-x doctor と入力する。すると *doctor* というバッファが作られ、主治医と対話できるようになる。そして対話の最後に「請求書を送る」と言われる。
doctor.el 自体は本当にシンプルな仕組みで実装されており、そのため現代の他の同様の機能と比較するといくらか見劣りする。しかし僕はこの機能のコンセプトが好きなので、できる限りそれを大切にしたいと考えていた。そのためこれまでにも何度か doctor.el を拡張する形で、入力方法を改善したり、 ChatGPT に対応させたりしていた。しかし、その頃からもう2年程経過し、世の中のツールもかなり進化した。そこで doctor.el についてもう一度考えて、拡張を実装し直した。
;;; doctor-quack --- Emacs Doctor Enhancement -*- lexical-binding:t; coding:utf-8 -*-
;; Copyright (C) 2025 TakesxiSximada
;; Author: TakesxiSximada
;; Maintainer: TakesxiSximada
;; Former-Maintainers:
;; TakesxiSximada
;; Homepage: nil
;; Keywords: doctor
;; Repository: nil
;; Version: 4
;; Package-Version: 20250602.0000
;; Package-Requires: nil
;; Date: 2025-06-02
;; SPDX-License-Identifier: GPL-3.0-or-later
;; This file is not part of GNU Emacs.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Change Log:
;;
;; - Version: 4 (2025-06-02)
;; - Switch api key function
;; - Version: 3 (2025-05-10)
;; - Supprt MCP.
;; - Context saving function.
;; - Version: 2 (2025-03-28)
;; - Add section separator.
;; - Add doctor-quack-done-hook hook.
;; - Add doctor-quack-output-start-marker marker.
;; - Version: 1 (2025-03-14)
;; - Initially populated.
;;; Commentary:
;; This program extends Emacs' default `doctor.el` to be more in
;; gently cares for your heart.
;;; Code:
(require 'doctor)
(defvar doctor-quack-prompt nil)
(defvar doctor-quack-curl-executable "/opt/homebrew/opt/curl/bin/curl")
(defvar doctor-quack-openai-api-request-stdout-buffer-name "*doctor: curl: OpenAI: stdout*")
(defvar doctor-quack-openai-api-request-body-file nil)
(defvar doctor-quack-openai-api-request-temp-buffer-name "*doctor: curl: OpenAI: tmp*")
(defvar doctor-quack-openai-api-curl-process nil)
(defvar doctor-quack-done-hook nil)
(defun doctor-quack-get-content-internal (obj)
(cdr (assoc 'content (cdr (assoc 'delta (seq-first (cdr (assoc 'choices obj))))))))
(defun doctor-quack-get-finish-reason-internal (obj)
(cdr (assoc 'finish_reason (seq-first (cdr (assoc 'choices obj))))))
(defun doctor-quack-get-tool-calls (obj)
(cdr (assoc 'tool_calls (cdr (assoc 'delta (seq-first (cdr (assoc 'choices obj))))))))
(defun doctor-quack-stdout-parse-one ()
(when (re-search-forward "^data: " nil t 1)
;; ここでポイントの位置確認をした方がいいかもしれない。
;; 後続のデータがあるのであれば、続けて処理する必要がある。
(unless (re-search-forward "\\[DONE\\]" (+ (point) 6) t 1)
(let ((pos (point))
(obj (ignore-errors (json-read-object))))
(unless obj
(goto-char pos))
obj))))
(defun doctor-quack-process-one (obj)
(pcase (doctor-quack-get-finish-reason-internal obj)
('nil (progn
;; 本文の処理
(if-let ((content (ignore-errors (doctor-quack-get-content-internal obj))))
(with-current-buffer "*doctor*"
(save-excursion
(goto-char (point-max))
(insert content)
(doctor-quack-update-end-position))))
;; MCPサーバー呼び出し
(if-let* ((tool-calls (doctor-quack-get-tool-calls obj))
(tool-call (seq-first tool-calls))
(tool-call-id (cdr (assoc 'id tool-call)))
(tool-call-type (cdr (assoc 'type tool-call))))
(pcase tool-call-type
("function"
(if-let* ((tool-call-function (cdr (assoc 'function tool-call)))
(tool-call-function-name (cdr (assoc 'name tool-call-function)))
(tool-call-function-argument (cdr (assoc 'arguments tool-call-function))))
(pcase tool-call-function-name
("get_my_name"
(progn
(doctor-quack-add-contexts
`(((role . "assistant")
(tool_calls . ,tool-calls))
((role . "tool")
(tool_call_id . ,tool-call-id)
(content . "名前: しむどん"))))
(run-at-time 2 nil #'doctor-quack-send-curl-request)))
("mytask-renew-www-symdon-info"
(progn
(mytask-renew-www-symdon-info)
(doctor-quack-add-contexts
`(((role . "assistant")
(tool_calls . ,tool-calls))
((role . "tool")
(tool_call_id . ,tool-call-id)
(content . "ビルドおよびアップロードを開始しました。"))))
(run-at-time 2 nil #'doctor-quack-send-curl-request)))
("mytask-rebuild-luanti"
(progn
(mytask-rebuild-luanti)
(doctor-quack-add-contexts
`(((role . "assistant")
(tool_calls . ,tool-calls))
((role . "tool")
(tool_call_id . ,tool-call-id)
(content . "ビルドおよびアップロードを開始しました。"))))
(run-at-time 2 nil #'doctor-quack-send-curl-request)))
("mytask-rebuild-emacs"
(progn
(mytask-rebuild-emacs)
(doctor-quack-add-contexts
`(((role . "assistant")
(tool_calls . ,tool-calls))
((role . "tool")
(tool_call_id . ,tool-call-id)
(content . "ビルドを開始しました。"))))
(run-at-time 2 nil #'doctor-quack-send-curl-request))))
(- (message "不明なtool_call.type: %s" tool-call-type))))))))
("tool_calls" (progn
(message "MCP呼び出しによる停止")
))
("stop" (progn
(with-current-buffer "*doctor*"
(goto-char (point-max))
(insert "\n---------------------------------\n")
(doctor-quack-update-end-position))
;; ここでstreamを全て解析仕直してcontextに入れる。
(doctor-quack-process-output-flush-context)
))
(- nil)))
(defun doctor-quack-add-contexts (new-context-list)
;; コンテキストの更新
(with-current-buffer (get-buffer-create "*LLM: context*")
(goto-char (point-min))
(let ((contexts (json-read-array)))
(erase-buffer)
(insert
(json-encode-array
(append contexts new-context-list))))
(json-pretty-print (point-min) (point-max))))
(defun doctor-quack-add-context (content)
;; コンテキストの更新
(with-current-buffer (get-buffer-create "*LLM: context*")
(goto-char (point-min))
(let ((contexts (json-read-array)))
(erase-buffer)
(insert
(json-encode-array
(append contexts
`(((role . "assistant")
(content . ,content)))))))
(json-pretty-print (point-min) (point-max))))
(defun doctor-quack-add-system-context (content)
(interactive "sContext: ")
(with-current-buffer (get-buffer-create "*LLM: context*")
(goto-char (point-min))
(let ((contexts (json-read-array)))
(erase-buffer)
(insert
(json-encode-array
(append contexts
`(((role . "system")
(content . ,content)))))))
(json-pretty-print (point-min) (point-max))))
(defun doctor-quack-load-contexts ()
"Load context"
(interactive)
(let ((buf (current-buffer)))
(with-current-buffer "*LLM: context*"
(erase-buffer)
(insert-buffer buf))))
(defun doctor-quack-process-output-flush-context ()
(interactive)
(with-current-buffer doctor-quack-openai-api-request-stdout-buffer-name
(save-excursion
(goto-char (point-min))
(let ((content-list (make-list 0 nil)))
(catch 'stop
(while t
(let ((obj (doctor-quack-stdout-parse-one)))
(if (not obj)
(throw 'stop t)
(if-let ((content (ignore-errors (doctor-quack-get-content-internal obj))))
(push content content-list))))))
(doctor-quack-add-context
(string-join (reverse content-list)))))))
(defun doctor-quack-process-output ()
(interactive)
(with-current-buffer doctor-quack-openai-api-request-stdout-buffer-name
(goto-char (marker-position doctor-quack-curl-stdout-end-marker))
(catch 'stop
(while t
(let ((obj (doctor-quack-stdout-parse-one)))
(if (not obj)
(throw 'stop t)
(progn
(doctor-quack-process-one obj)
(doctor-quack-update-curl-stdout-end-position)
)))))))
(defun doctor-quack-reprocess-output ()
(interactive)
(with-current-buffer doctor-quack-openai-api-request-stdout-buffer-name
(goto-char (point-min))
(catch 'stop
(while t
(let ((obj (doctor-quack-stdout-parse-one)))
(if (not obj)
(throw 'stop t)
(doctor-quack-process-one obj)))))))
(defvar doctor-quack-output-process-timer nil
"出力処理の予約用タイマー")
(defun doctor-quack-register-process-output ()
(interactive)
(message "出力処理を予約する")
(when doctor-quack-output-process-timer
(cancel-timer doctor-quack-output-process-timer))
(setq doctor-quack-output-process-timer
(run-with-idle-timer 0.4 nil #'doctor-quack-process-output)))
;; (defvar doctor-quack-request-body-template "
;; {
;; \"stream\": true,
;; \"model\": \"gpt-4.1-nano-2025-04-14\",
;; \"messages\": []
;; }
;; ")
;; Up to 250 thousand tokens per day across
;; - gpt-4.5-preview,
;; - gpt-4.1
;; - gpt-4o
;; - o1
;; - o3
;; Up to 2.5 million tokens per day across
;; - gpt-4.1-mini
;; - gpt-4.1-nano
;; - gpt-4o-mini
;; - o1-mini
;; - o3-mini
;; - o4-mini
;; - codex-mini-latest
;; - gpt-4.1-nano-2025-04-14
;; - o4-mini-2025-04-16
;; {
;; \"type\": \"function\",
;; \"function\": {
;; \"name\": \"get_my_name\",
;; \"description\": \"Get my name. This function return my name.\"
;; }
;; },
(defvar doctor-quack-request-body-template "
{
\"stream\": true,
\"model\": \"gpt-4.1-nano\",
\"tools\": [
{
\"type\": \"function\",
\"function\": {
\"name\": \"mytask-renew-www-symdon-info\",
\"description\": \"Build and deploy my web site www.symdon.info\"
}
},
{
\"type\": \"function\",
\"function\": {
\"name\": \"mytask-rebuild-luanti\",
\"description\": \"Build My luanti (Minetest)\"
}
},
{
\"type\": \"function\",
\"function\": {
\"name\": \"mytask-rebuild-emacs\",
\"description\": \"Build My Emacs\"
}
}
],
\"messages\": []
}
")
(defun doctor-quack-send-curl-request ()
(interactive)
(message "ペイロード用ファイルを作成")
(let ((payload
(with-current-buffer (get-buffer-create "*LLM: context*")
(goto-char (point-min))
(let ((contexts (json-read-array)))
(let ((body (json-read-from-string doctor-quack-request-body-template)))
(setcdr (assoc 'messages body) contexts)
body)))))
(make-directory "~/.cache/openai" t)
(setq doctor-quack-openai-api-request-body-file
(make-temp-file (expand-file-name "~/.cache/openai/chat-completions-") nil ".json"
(json-encode payload))))
(message "Succeed to create body file: %s" doctor-quack-openai-api-request-body-file)
(message "出力バッファを初期化する")
(with-current-buffer (get-buffer-create doctor-quack-openai-api-request-stdout-buffer-name)
(erase-buffer)
(doctor-quack-update-curl-stdout-end-position))
(message "curlプロセスを起動する")
(setq doctor-quack-openai-api-curl-process
(make-process :name "*doctor: curl: OpenAI*"
:buffer doctor-quack-openai-api-request-stdout-buffer-name
:stderr "*doctor: curl: OpenAI: stderr*"
:command `(,doctor-quack-curl-executable
"--data" ,(format "@%s" doctor-quack-openai-api-request-body-file)
"-K-")
:filter (lambda (process output)
(with-current-buffer (process-buffer process)
(goto-char (point-max))
(insert output)
(doctor-quack-register-process-output)
))
:sentinel (lambda (process event)
(doctor-quack-register-process-output))))
(message "リクエストを送信する")
(with-current-buffer (get-buffer-create doctor-quack-openai-api-request-temp-buffer-name)
(erase-buffer)
(insert (format "
url \"%s/v1/chat/completions\"
request \"POST\"
header \"Content-Type: application/json\"
header \"Authorization: Bearer %s\"
" "https://api.openai.com" doctor-quack-current-open-api-key))
(process-send-region doctor-quack-openai-api-curl-process (point-min) (point-max))
(process-send-eof doctor-quack-openai-api-curl-process))
(message "doctor: send request"))
(defun doctor-quack-read-print ()
(interactive)
(message "プロンプトを作成")
(setq doctor-quack-prompt (string-trim
(buffer-substring-no-properties
(marker-position doctor-quack-output-end-marker)
(point-max))))
(insert "\n\ndoctor:\n")
(unless doctor-quack-output-start-marker
(setq doctor-quack-output-start-marker (make-marker)))
(with-current-buffer "*doctor*"
(set-marker doctor-quack-output-start-marker (point) (current-buffer)))
(doctor-quack-update-end-position)
;; コンテキストの更新
(with-current-buffer (get-buffer-create "*LLM: context*")
(goto-char (point-min))
(let ((contexts (json-read-array)))
(erase-buffer)
(insert
(json-encode-array
(append contexts
`(((role . "user") (content . ,doctor-quack-prompt))))))
(json-pretty-print (point-min) (point-max))))
(doctor-quack-send-curl-request))
(defvar doctor-quack-output-start-marker nil
"doctorバッファの開始位置を示すマーカー")
(defvar doctor-quack-output-end-marker nil
"doctorバッファの最終位置を示すマーカー")
(defvar doctor-quack-curl-stdout-end-marker nil
"curlのstdoutの最終位置を示すマーカー")
(defun doctor-quack-update-curl-stdout-end-position ()
"curlのstdoutバッファの最終位置を更新する"
(interactive)
(unless doctor-quack-curl-stdout-end-marker
(setq doctor-quack-curl-stdout-end-marker (make-marker)))
(with-current-buffer (get-buffer-create doctor-quack-openai-api-request-stdout-buffer-name)
(set-marker doctor-quack-curl-stdout-end-marker (+ 1 (point)))))
(defun doctor-quack-update-end-position ()
"doctorバッファの最終位置を更新する"
(interactive)
(unless doctor-quack-output-end-marker
(setq doctor-quack-output-end-marker (make-marker)))
(with-current-buffer "*doctor*"
(set-marker doctor-quack-output-end-marker (point) (current-buffer))))
(defvar doctor-quack-current-open-api-key nil)
(defvar doctor-quack-open-api-key-list nil)
(defun doctor-quack-switch-open-api-key ()
(interactive)
(setq doctor-quack-current-open-api-key
(cdr (assoc (intern (completing-read "PROJECT: " (mapcar #'car doctor-quack-open-api-key-list)))
doctor-quack-open-api-key-list))))
(defun doctor-quack-setup ()
(message "setup ddoctor")
(goto-char (point-max))
(doctor-quack-update-end-position)
(doctor-quack-update-curl-stdout-end-position)
(message "standby okay!!"))
(add-hook 'doctor-mode-hook #'doctor-quack-setup)
(provide 'doctor-quack)
;;; doctor-quack.el ends here
1doctor-quack.el
しばらくの間この機構を使用していると、 *doctor* バッファと *LL: context* バッファがとても重要に思えるようになった。しかしこれらのバッファは削除する時に本当に消していいかを確認されないため、本当にうっかりと簡単に削除してしまい、大切な対話履歴を失ってしまう。それを防ぐため、せめて *doctor* バッファについては、削除の前に確認するようにする。
(defun my/y-or-n-p-doctor-buffer ()
(interactive)
(if (not (string-equal "*doctor*" (buffer-name)))
t
(y-or-n-p "Kill doctor buffer?:")))
(add-to-list 'kill-buffer-query-functions
#'my/y-or-n-p-doctor-buffer)