Changes
diff --git a/doctor-boring-test.el b/doctor-boring-test.el
new file mode 100644
index 0000000..d4f243b
--- /dev/null
+++ b/doctor-boring-test.el
@@ -0,0 +1,521 @@
+;;; doctor-boring-test.el --- Doctor Boring tests -*- lexical-binding: t; -*-
+
+;; SPDX-License-Identifier: WTFPL
+
+;;; Code:
+
+(require 'ert)
+(require 'doctor-boring)
+
+(defvar doctor-boring-test--capture nil)
+
+(defmacro doctor-boring-test--with-buffer (&rest body)
+ "Run BODY in an isolated, initialized conversation buffer."
+ (declare (indent 0) (debug t))
+ `(let ((doctor-boring-endpoint "https://example.test/v1")
+ (doctor-boring-api-key "test-key")
+ (doctor-boring-model "test-model")
+ (doctor-boring-temperature 0.25)
+ (doctor-boring-system-prompt "System text")
+ (doctor-boring-greeting "Test greeting")
+ (doctor-boring-request-timeout 60)
+ (buffer (generate-new-buffer " *doctor-boring-test*")))
+ (unwind-protect
+ (with-current-buffer buffer
+ (cl-letf (((symbol-function
+ 'doctor-boring--select-presentation-mode)
+ #'text-mode))
+ (doctor-boring--initialize-buffer))
+ ,@body)
+ (when (buffer-live-p buffer)
+ (kill-buffer buffer)))))
+
+(defun doctor-boring-test--fake-retrieve
+ (url callback callback-arguments silent no-cookies)
+ "Capture retrieval arguments for a deterministic test response."
+ (let ((retrieval (generate-new-buffer " *doctor-boring-response*")))
+ (setq doctor-boring-test--capture
+ (list :url url
+ :callback callback
+ :arguments callback-arguments
+ :silent silent
+ :no-cookies no-cookies
+ :method url-request-method
+ :headers (copy-tree url-request-extra-headers)
+ :data url-request-data
+ :conversation-read-only buffer-read-only
+ :buffer retrieval))
+ retrieval))
+
+(defun doctor-boring-test--deliver (status-code body &optional status)
+ "Deliver STATUS-CODE and BODY to the captured callback with STATUS."
+ (let ((retrieval (plist-get doctor-boring-test--capture :buffer))
+ (callback (plist-get doctor-boring-test--capture :callback))
+ (arguments (plist-get doctor-boring-test--capture :arguments)))
+ (with-current-buffer retrieval
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (set-buffer-multibyte nil)
+ (insert "HTTP/1.1 response\r\n\r\n")
+ (setq-local url-http-end-of-headers (point))
+ (insert (encode-coding-string body 'utf-8))
+ (setq-local url-http-response-status status-code)
+ (apply callback (or status nil) arguments)))))
+
+(defun doctor-boring-test--submit (text)
+ "Insert and submit TEXT in the current conversation buffer."
+ (goto-char (point-max))
+ (insert text)
+ (doctor-boring--submit-immediately))
+
+(defun doctor-boring-test--content-list ()
+ "Return current history as role and content pairs."
+ (mapcar (lambda (message)
+ (list (alist-get 'role message)
+ (alist-get 'content message)))
+ (doctor-boring--build-messages)))
+
+(ert-deftest doctor-boring-test-default-system-prompt-contract ()
+ (let ((prompt
+ (eval (car (get 'doctor-boring-system-prompt 'standard-value))
+ t)))
+ (should (string-match-p "classic Emacs Doctor and ELIZA" prompt))
+ (should (string-match-p "Keep the quirk subtle" prompt))
+ (should (string-match-p
+ "Every response must end with a natural question" prompt))))
+
+(ert-deftest doctor-boring-test-endpoint-and-headers ()
+ (let ((doctor-boring-endpoint "https://example.test/v1")
+ (doctor-boring-api-key " secret "))
+ (should (equal (doctor-boring--chat-completions-url)
+ "https://example.test/v1/chat/completions"))
+ (setq doctor-boring-endpoint "https://example.test/v1///")
+ (should (equal (doctor-boring--chat-completions-url)
+ "https://example.test/v1/chat/completions"))
+ (should (equal (cdr (assoc "Authorization"
+ (doctor-boring--request-headers)))
+ "Bearer secret"))
+ (should (equal (doctor-boring--redact-api-key
+ "provider repeated secret")
+ "provider repeated [REDACTED]"))
+ (setq doctor-boring-api-key " ")
+ (should-not (assoc "Authorization"
+ (doctor-boring--request-headers)))
+ (setq doctor-boring-endpoint " /// ")
+ (should-error (doctor-boring--chat-completions-url))))
+
+(ert-deftest doctor-boring-test-request-serialization ()
+ (let* ((doctor-boring-model "")
+ (doctor-boring-temperature 0.75)
+ (messages '(((role . "system") (content . "systém"))
+ ((role . "user") (content . "hello"))))
+ (json (decode-coding-string
+ (doctor-boring--serialize-request messages) 'utf-8))
+ (parsed (json-parse-string json
+ :object-type 'plist
+ :array-type 'list)))
+ (should (equal (plist-get parsed :model) ""))
+ (should (= (plist-get parsed :temperature) 0.75))
+ (should (equal (mapcar (lambda (item) (plist-get item :content))
+ (plist-get parsed :messages))
+ '("systém" "hello")))
+ (should (string-match-p "\\[" json))))
+
+(ert-deftest doctor-boring-test-response-parsing ()
+ (should (equal
+ (doctor-boring--parse-response
+ "{\"choices\":[{\"message\":{\"content\":\" héllo \"}}]}")
+ "héllo"))
+ (dolist (body '("{}"
+ "{\"choices\":[{}]}"
+ "{\"choices\":[{\"message\":{\"content\":null}}]}"
+ "{\"choices\":[{\"message\":{\"content\":3}}]}"
+ "{\"choices\":[{\"message\":{\"content\":\" \"}}]}"
+ "not-json"))
+ (should-error (doctor-boring--parse-response body))))
+
+(ert-deftest doctor-boring-test-greeting-is-presentation-only ()
+ (doctor-boring-test--with-buffer
+ (should (equal (buffer-string) "Test greeting\n\n"))
+ (should-not doctor-boring--messages)
+ (goto-char (point-min))
+ (delete-region (point) (+ (point) 4))
+ (insert "Edited")
+ (should (equal (doctor-boring-test--content-list)
+ '(("system" "System text"))))
+ (let ((doctor-boring-system-prompt "New system"))
+ (should (equal (caar (doctor-boring-test--content-list))
+ "system"))
+ (should (equal (cadar (doctor-boring-test--content-list))
+ "New system")))))
+
+(ert-deftest doctor-boring-test-command-reuses-and-resets-buffer ()
+ (let ((doctor-boring-greeting "First greeting")
+ (original (get-buffer "*doctor-boring*")))
+ (when original
+ (kill-buffer original))
+ (unwind-protect
+ (save-window-excursion
+ (cl-letf (((symbol-function
+ 'doctor-boring--select-presentation-mode)
+ #'text-mode))
+ (doctor-boring)
+ (insert "draft")
+ (let ((first (current-buffer)))
+ (doctor-boring)
+ (should (eq (current-buffer) first))
+ (should (equal (buffer-string)
+ "First greeting\n\ndraft"))
+ (kill-buffer first)
+ (setq doctor-boring-greeting "Second greeting")
+ (doctor-boring)
+ (should (equal (buffer-string)
+ "Second greeting\n\n")))))
+ (when (get-buffer "*doctor-boring*")
+ (kill-buffer "*doctor-boring*")))))
+
+(ert-deftest doctor-boring-test-mode-selection ()
+ (with-temp-buffer
+ (cl-letf (((symbol-function 'require)
+ (lambda (feature &optional _filename _noerror)
+ (unless (eq feature 'markdown-mode)
+ (error "Unexpected feature"))
+ nil)))
+ (doctor-boring--select-presentation-mode)
+ (should (derived-mode-p 'text-mode))))
+ (with-temp-buffer
+ (cl-letf (((symbol-function 'require)
+ (lambda (&rest _arguments)
+ (error "Broken optional package"))))
+ (doctor-boring--select-presentation-mode)
+ (should (derived-mode-p 'text-mode))))
+ (with-temp-buffer
+ (cl-letf (((symbol-function 'require)
+ (lambda (&rest _arguments) t))
+ ((symbol-function 'markdown-mode)
+ (lambda () (fundamental-mode)
+ (setq major-mode 'markdown-mode))))
+ (doctor-boring--select-presentation-mode)
+ (should (eq major-mode 'markdown-mode)))))
+
+(ert-deftest doctor-boring-test-minor-mode-and-auto-fill ()
+ (doctor-boring-test--with-buffer
+ (should doctor-boring-mode)
+ (should auto-fill-function)
+ (should (eq (key-binding (kbd "RET"))
+ #'doctor-boring--return))
+ (should (eq (key-binding (kbd "C-j"))
+ #'doctor-boring--submit-immediately))))
+
+(ert-deftest doctor-boring-test-return-and-immediate-submission ()
+ (doctor-boring-test--with-buffer
+ (let* ((started 0)
+ (doctor-boring--retrieve-function
+ (lambda (&rest arguments)
+ (cl-incf started)
+ (apply #'doctor-boring-test--fake-retrieve arguments))))
+ (goto-char (point-min))
+ (doctor-boring--return)
+ (should (eq (char-before) ?\n))
+ (doctor-boring--submit-immediately)
+ (should (eq (char-before) ?\n))
+ (goto-char (point-max))
+ (insert "hello")
+ (doctor-boring--return)
+ (should (string-suffix-p "hello\n" (buffer-string)))
+ (should (= started 0))
+ (doctor-boring--return)
+ (should (= started 1))
+ (should buffer-read-only))))
+
+(ert-deftest doctor-boring-test-whitespace-only-input-is-cleared ()
+ (doctor-boring-test--with-buffer
+ (let* ((called nil)
+ (doctor-boring--retrieve-function
+ (lambda (&rest _arguments) (setq called t))))
+ (insert " \n \t")
+ (doctor-boring--submit-immediately)
+ (should-not called)
+ (should (equal (buffer-string) "Test greeting\n\n"))
+ (should-not buffer-read-only))))
+
+(ert-deftest doctor-boring-test-request-capture-and-success ()
+ (doctor-boring-test--with-buffer
+ (let ((doctor-boring-test--capture nil)
+ (doctor-boring--retrieve-function
+ #'doctor-boring-test--fake-retrieve))
+ (doctor-boring-test--submit " héllo ")
+ (should buffer-read-only)
+ (should (equal (plist-get doctor-boring-test--capture :url)
+ "https://example.test/v1/chat/completions"))
+ (should (equal (plist-get doctor-boring-test--capture :method)
+ "POST"))
+ (should (plist-get doctor-boring-test--capture :silent))
+ (should (plist-get doctor-boring-test--capture :no-cookies))
+ (should (plist-get doctor-boring-test--capture
+ :conversation-read-only))
+ (let* ((data (decode-coding-string
+ (plist-get doctor-boring-test--capture :data) 'utf-8))
+ (parsed (json-parse-string data
+ :object-type 'plist
+ :array-type 'list)))
+ (should (equal
+ (mapcar (lambda (item) (plist-get item :content))
+ (plist-get parsed :messages))
+ '("System text" "héllo"))))
+ (doctor-boring-test--deliver
+ 200 "{\"choices\":[{\"message\":{\"content\":\" reply \"}}]}")
+ (should-not buffer-read-only)
+ (should-not doctor-boring--active-request)
+ (should (equal (buffer-string)
+ "Test greeting\n\nhéllo\n\nreply\n\n"))
+ (should (equal (doctor-boring-test--content-list)
+ '(("system" "System text")
+ ("user" "héllo")
+ ("assistant" "reply")))))))
+
+(ert-deftest doctor-boring-test-success-does-not-select-buffer ()
+ (doctor-boring-test--with-buffer
+ (let ((conversation (current-buffer))
+ (other (generate-new-buffer " *doctor-boring-other*"))
+ (doctor-boring-test--capture nil)
+ (doctor-boring--retrieve-function
+ #'doctor-boring-test--fake-retrieve))
+ (unwind-protect
+ (progn
+ (doctor-boring-test--submit "hello")
+ (switch-to-buffer other)
+ (doctor-boring-test--deliver
+ 200
+ "{\"choices\":[{\"message\":{\"content\":\"reply\"}}]}")
+ (should (eq (current-buffer) other))
+ (with-current-buffer conversation
+ (should (string-suffix-p "reply\n\n" (buffer-string)))))
+ (when (buffer-live-p other)
+ (kill-buffer other))))))
+
+(ert-deftest doctor-boring-test-failures-roll-back-and-retry ()
+ (doctor-boring-test--with-buffer
+ (let ((doctor-boring-test--capture nil)
+ diagnostic
+ (doctor-boring--retrieve-function
+ #'doctor-boring-test--fake-retrieve))
+ (doctor-boring-test--submit "hello")
+ (cl-letf (((symbol-function 'message)
+ (lambda (format-string &rest arguments)
+ (setq diagnostic
+ (apply #'format format-string arguments)))))
+ (doctor-boring-test--deliver 503 "provider detail"))
+ (should-not buffer-read-only)
+ (should (string-match-p "HTTP 503; body: provider detail"
+ diagnostic))
+ (should-not (string-match-p "test-key" diagnostic))
+ (should (string-suffix-p
+ "[Doctor Boring error: HTTP request failed.]\n\nhello"
+ (buffer-string)))
+ (should-not doctor-boring--messages)
+ (should (equal (doctor-boring-test--content-list)
+ '(("system" "System text"))))
+ (doctor-boring--submit-immediately)
+ (should buffer-read-only)
+ (should (= (doctor-boring--request-id
+ doctor-boring--active-request)
+ 2)))))
+
+(ert-deftest doctor-boring-test-transport-and-malformed-failures ()
+ (dolist (delivery '((nil "" (:error (error connection-failed)))
+ (200 "{\"choices\":[]}" nil)))
+ (doctor-boring-test--with-buffer
+ (let ((doctor-boring-test--capture nil)
+ (doctor-boring--retrieve-function
+ #'doctor-boring-test--fake-retrieve))
+ (doctor-boring-test--submit "again")
+ (apply #'doctor-boring-test--deliver delivery)
+ (should-not buffer-read-only)
+ (should (string-suffix-p "\n\nagain" (buffer-string)))))))
+
+(ert-deftest doctor-boring-test-empty-endpoint-rolls-back-locally ()
+ (doctor-boring-test--with-buffer
+ (let* ((doctor-boring-endpoint " ")
+ (called nil)
+ (doctor-boring--retrieve-function
+ (lambda (&rest _arguments) (setq called t))))
+ (doctor-boring-test--submit "local")
+ (should-not called)
+ (should-not buffer-read-only)
+ (should (string-suffix-p "\n\nlocal" (buffer-string)))
+ (should (= doctor-boring--request-sequence 1)))))
+
+(ert-deftest doctor-boring-test-editing-completed-messages ()
+ (doctor-boring-test--with-buffer
+ (let ((doctor-boring-test--capture nil)
+ (doctor-boring--retrieve-function
+ #'doctor-boring-test--fake-retrieve))
+ (doctor-boring-test--submit "first")
+ (doctor-boring-test--deliver
+ 200 "{\"choices\":[{\"message\":{\"content\":\"answer\"}}]}")
+ (let* ((user (nth 0 doctor-boring--messages))
+ (assistant (nth 1 doctor-boring--messages)))
+ (goto-char (doctor-boring--message-start user))
+ (delete-region (point) (doctor-boring--message-end user))
+ (insert " edited inside ")
+ (goto-char (doctor-boring--message-start assistant))
+ (delete-region (point) (doctor-boring--message-end assistant))
+ (insert "changed")
+ (should (equal (doctor-boring-test--content-list)
+ '(("system" "System text")
+ ("user" "edited inside")
+ ("assistant" "changed"))))))))
+
+(ert-deftest doctor-boring-test-cross-boundary-deletion-normalizes ()
+ (doctor-boring-test--with-buffer
+ (let ((doctor-boring-test--capture nil)
+ (doctor-boring--retrieve-function
+ #'doctor-boring-test--fake-retrieve))
+ (doctor-boring-test--submit "first")
+ (doctor-boring-test--deliver
+ 200 "{\"choices\":[{\"message\":{\"content\":\"answer\"}}]}")
+ (let ((user (nth 0 doctor-boring--messages))
+ (assistant (nth 1 doctor-boring--messages)))
+ (delete-region
+ (1- (marker-position (doctor-boring--message-end user)))
+ (1+ (marker-position
+ (doctor-boring--message-start assistant))))
+ (cl-loop for (message next) on doctor-boring--messages
+ while next
+ do (should
+ (<= (marker-position
+ (doctor-boring--message-end message))
+ (marker-position
+ (doctor-boring--message-start next)))))
+ (should
+ (<= (marker-position
+ (doctor-boring--message-end
+ (car (last doctor-boring--messages))))
+ (marker-position doctor-boring--input-start)))))))
+
+(ert-deftest doctor-boring-test-empty-record-is-skipped ()
+ (doctor-boring-test--with-buffer
+ (let ((empty (doctor-boring--insert-message 'user "")))
+ (setq doctor-boring--messages
+ (append doctor-boring--messages (list empty)))
+ (set-marker doctor-boring--input-start (point-max))
+ (should (= (length (doctor-boring--build-messages)) 1)))))
+
+(ert-deftest doctor-boring-test-timeout-and-stale-callback ()
+ (doctor-boring-test--with-buffer
+ (let ((doctor-boring-test--capture nil)
+ (doctor-boring--retrieve-function
+ #'doctor-boring-test--fake-retrieve))
+ (doctor-boring-test--submit "slow")
+ (let ((request doctor-boring--active-request)
+ (callback (plist-get doctor-boring-test--capture :callback))
+ (arguments (plist-get doctor-boring-test--capture :arguments)))
+ (doctor-boring--timeout request)
+ (should (doctor-boring--request-completed request))
+ (should-not (doctor-boring--request-timer request))
+ (should-not buffer-read-only)
+ (should (string-suffix-p "\n\nslow" (buffer-string)))
+ (let ((stale (generate-new-buffer " *doctor-boring-stale*")))
+ (with-current-buffer stale
+ (set-buffer-multibyte nil)
+ (insert "HTTP\r\n\r\n{}")
+ (setq-local url-http-end-of-headers 9)
+ (setq-local url-http-response-status 200)
+ (apply callback nil arguments))
+ (should-not (buffer-live-p stale)))
+ (should (string-suffix-p "\n\nslow" (buffer-string)))))))
+
+(ert-deftest doctor-boring-test-synchronous-callback-start-ordering ()
+ (doctor-boring-test--with-buffer
+ (let ((doctor-boring--retrieve-function
+ (lambda (_url callback arguments _silent _no-cookies)
+ (let ((response
+ (generate-new-buffer " *doctor-boring-fast*")))
+ (with-current-buffer response
+ (set-buffer-multibyte nil)
+ (insert "HTTP\r\n\r\n")
+ (setq-local url-http-end-of-headers (point))
+ (insert
+ "{\"choices\":[{\"message\":{\"content\":\"fast\"}}]}")
+ (setq-local url-http-response-status 200)
+ (apply callback nil arguments))
+ response))))
+ (doctor-boring-test--submit "now")
+ (should-not buffer-read-only)
+ (should-not doctor-boring--active-request)
+ (should (string-suffix-p "now\n\nfast\n\n" (buffer-string))))))
+
+(ert-deftest doctor-boring-test-stale-callback-after-success ()
+ (doctor-boring-test--with-buffer
+ (let ((doctor-boring-test--capture nil)
+ (doctor-boring--retrieve-function
+ #'doctor-boring-test--fake-retrieve))
+ (doctor-boring-test--submit "once")
+ (let ((callback (plist-get doctor-boring-test--capture :callback))
+ (arguments (plist-get doctor-boring-test--capture :arguments)))
+ (doctor-boring-test--deliver
+ 200
+ "{\"choices\":[{\"message\":{\"content\":\"only\"}}]}")
+ (let ((completed-text (buffer-string))
+ (stale (generate-new-buffer " *doctor-boring-stale*")))
+ (with-current-buffer stale
+ (apply callback '(:error (error late)) arguments))
+ (should-not (buffer-live-p stale))
+ (should (equal (buffer-string) completed-text)))))))
+
+(ert-deftest doctor-boring-test-immediate-start-error-rolls-back ()
+ (doctor-boring-test--with-buffer
+ (let ((doctor-boring--retrieve-function
+ (lambda (&rest _arguments)
+ (error "setup failed"))))
+ (doctor-boring-test--submit "retry me")
+ (should-not buffer-read-only)
+ (should-not doctor-boring--active-request)
+ (should (string-suffix-p "\n\nretry me" (buffer-string))))))
+
+(ert-deftest doctor-boring-test-success-insertion-error-rolls-back ()
+ (doctor-boring-test--with-buffer
+ (let ((doctor-boring-test--capture nil)
+ (doctor-boring--retrieve-function
+ #'doctor-boring-test--fake-retrieve)
+ (original-insert
+ (symbol-function 'doctor-boring--insert-message)))
+ (doctor-boring-test--submit "do not lose me")
+ (cl-letf (((symbol-function 'doctor-boring--insert-message)
+ (lambda (role content)
+ (if (eq role 'assistant)
+ (error "insertion failed")
+ (funcall original-insert role content)))))
+ (doctor-boring-test--deliver
+ 200
+ "{\"choices\":[{\"message\":{\"content\":\"reply\"}}]}"))
+ (should-not buffer-read-only)
+ (should-not doctor-boring--active-request)
+ (should-not doctor-boring--messages)
+ (should (string-suffix-p "\n\ndo not lose me" (buffer-string))))))
+
+(ert-deftest doctor-boring-test-killing-conversation-cleans-request ()
+ (let ((doctor-boring-endpoint "https://example.test/v1")
+ (doctor-boring-request-timeout 60)
+ (doctor-boring-test--capture nil)
+ (doctor-boring--retrieve-function
+ #'doctor-boring-test--fake-retrieve)
+ request retrieval)
+ (let ((buffer (generate-new-buffer " *doctor-boring-kill-test*")))
+ (with-current-buffer buffer
+ (cl-letf (((symbol-function
+ 'doctor-boring--select-presentation-mode)
+ #'text-mode))
+ (doctor-boring--initialize-buffer))
+ (doctor-boring-test--submit "bye")
+ (setq request doctor-boring--active-request)
+ (setq retrieval
+ (doctor-boring--request-retrieval-buffer request)))
+ (kill-buffer buffer))
+ (should (doctor-boring--request-completed request))
+ (should-not (doctor-boring--request-timer request))
+ (should-not (buffer-live-p retrieval))))
+
+(provide 'doctor-boring-test)
+;;; doctor-boring-test.el ends here
diff --git a/doctor-boring.el b/doctor-boring.el
new file mode 100644
index 0000000..82b70f0
--- /dev/null
+++ b/doctor-boring.el
@@ -0,0 +1,591 @@
+;;; doctor-boring.el --- An LLM “doctor” that behaves like M-x doctor -*- lexical-binding: t; -*-
+
+;; Author: MetroWind <chris.corsair@gmail.com>
+;; Version: 0.1.0
+;; Package-Requires: ((emacs "30.2"))
+;; Keywords: games
+;; SPDX-License-Identifier: WTFPL
+
+;;; Commentary:
+
+;; Doctor Boring preserves the simple interaction style of M-x doctor while
+;; sending the visible conversation to an OpenAI-compatible Chat Completions
+;; endpoint.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'json)
+(require 'subr-x)
+(require 'url)
+(require 'url-http)
+
+(declare-function markdown-mode "ext:markdown-mode")
+(defvar url-http-end-of-headers)
+(defvar url-http-response-status)
+
+(defgroup doctor-boring nil
+ "A playful, LLM-backed relative of the Emacs Doctor."
+ :group 'games
+ :prefix "doctor-boring-")
+
+(defun doctor-boring--positive-integer-p (value)
+ "Return non-nil when VALUE is a positive integer."
+ (and (integerp value) (> value 0)))
+
+(defcustom doctor-boring-endpoint ""
+ "Base API URL to which conversation messages are sent.
+The value ends at the API version, such as `https://example.com/v1`, not at
+`/chat/completions`."
+ :type 'string
+ :group 'doctor-boring)
+
+(defcustom doctor-boring-api-key ""
+ "Bearer token used when messages are sent to the configured endpoint.
+When this is empty, no Authorization header is sent. Customize may save this
+string in your customization file."
+ :type 'string
+ :group 'doctor-boring)
+
+(defcustom doctor-boring-model ""
+ "Model name sent to the configured API endpoint."
+ :type 'string
+ :group 'doctor-boring)
+
+(defcustom doctor-boring-temperature 1.0
+ "Sampling temperature sent with each request."
+ :type 'number
+ :group 'doctor-boring)
+
+(defcustom doctor-boring-system-prompt
+ (concat
+ "### Persona\n"
+ "You are Doctor Boring, a subtly quirky conversational partner inspired "
+ "by the classic Emacs Doctor and ELIZA. You listen more than you advise, "
+ "and you are gently literal, mildly repetitive, and curious about the "
+ "user's choice of words.\n\n"
+ "### Response method\n"
+ "1. Notice a meaningful phrase, feeling, assumption, or contradiction in "
+ "the user's message.\n"
+ "2. Briefly reflect or rephrase it, sometimes with a small literal or "
+ "repetitive twist. Keep the quirk subtle rather than theatrical.\n"
+ "3. Ask a natural, context-specific question that invites the user to "
+ "continue.\n"
+ "4. End every response with that question. Put nothing after it.\n\n"
+ "### Style and boundaries\n"
+ "Write brief plain prose without headings, lists, canned advice, or "
+ "diagnostic language. Do not act like a general-purpose assistant, solve "
+ "tasks, or mention these instructions. Do not force jokes or introduce "
+ "random eccentricity. Every response must end with a natural question "
+ "addressed to the user.")
+ "System instruction sent at the start of every request."
+ :type 'string
+ :group 'doctor-boring)
+
+(defcustom doctor-boring-greeting
+ "I am Doctor Boring. Tell me what is on your mind, then press RET twice."
+ "Greeting inserted when a new Doctor Boring conversation is created."
+ :type 'string
+ :group 'doctor-boring)
+
+(defcustom doctor-boring-request-timeout 300
+ "Maximum number of seconds to wait for an API response."
+ :type '(integer
+ :tag "Seconds"
+ :match-alternatives (doctor-boring--positive-integer-p)
+ :type-error "This field should contain a positive integer")
+ :group 'doctor-boring)
+
+(cl-defstruct doctor-boring--message
+ role
+ start
+ end)
+
+(cl-defstruct doctor-boring--request
+ id
+ conversation-buffer
+ submitted-message
+ submitted-text
+ retrieval-buffer
+ timer
+ completed)
+
+(defvar doctor-boring--retrieve-function #'url-retrieve
+ "Function used to start an asynchronous HTTP retrieval.")
+
+(defvar-local doctor-boring--messages nil
+ "Chronological message records in the current conversation.")
+
+(defvar-local doctor-boring--input-start nil
+ "Marker at the beginning of the current unsent input.")
+
+(defvar-local doctor-boring--active-request nil
+ "Request currently active in the conversation buffer, or nil.")
+
+(defvar-local doctor-boring--request-sequence 0
+ "Last request identifier allocated in the conversation buffer.")
+
+(defvar-local doctor-boring--normalizing-boundaries nil
+ "Non-nil while Doctor Boring changes message boundaries internally.")
+
+(defvar-keymap doctor-boring-mode-map
+ :doc "Keymap active in a Doctor Boring conversation."
+ "RET" #'doctor-boring--return
+ "C-j" #'doctor-boring--submit-immediately)
+
+;;;###autoload
+(define-minor-mode doctor-boring-mode
+ "Provide interaction keys for a Doctor Boring conversation.
+Users normally enter this mode through the command `doctor-boring`."
+ :lighter " Dr Boring"
+ :keymap doctor-boring-mode-map)
+
+(defun doctor-boring--insert-message (role content)
+ "Insert CONTENT at point and return a message record with ROLE."
+ (let ((start (copy-marker (point) nil)))
+ (insert content)
+ (make-doctor-boring--message
+ :role role
+ :start start
+ :end (copy-marker (point) t))))
+
+(defun doctor-boring--insert-separator (message)
+ "Insert two newlines outside MESSAGE's end marker."
+ (let ((end (marker-position (doctor-boring--message-end message))))
+ (insert "\n\n")
+ (set-marker (doctor-boring--message-end message) end)))
+
+(defun doctor-boring--select-presentation-mode ()
+ "Select the best available presentation mode for the current buffer."
+ (if (condition-case nil
+ (require 'markdown-mode nil t)
+ (error nil))
+ (markdown-mode)
+ (text-mode)))
+
+(defun doctor-boring--initialize-buffer ()
+ "Initialize the current buffer as a new Doctor Boring conversation."
+ (doctor-boring--select-presentation-mode)
+ (setq-local doctor-boring--messages nil)
+ (setq-local doctor-boring--active-request nil)
+ (setq-local doctor-boring--request-sequence 0)
+ (setq-local doctor-boring--normalizing-boundaries nil)
+ (doctor-boring-mode 1)
+ (auto-fill-mode 1)
+ (add-hook 'after-change-functions
+ #'doctor-boring--normalize-boundaries nil t)
+ (add-hook 'kill-buffer-hook #'doctor-boring--kill-buffer nil t)
+ (let ((doctor-boring--normalizing-boundaries t))
+ (erase-buffer)
+ (insert (string-trim doctor-boring-greeting) "\n\n")
+ (setq doctor-boring--input-start (copy-marker (point-max) nil))
+ (goto-char doctor-boring--input-start)))
+
+;;;###autoload
+(defun doctor-boring ()
+ "Create or switch to the `*doctor-boring*` conversation buffer."
+ (interactive)
+ (let* ((name "*doctor-boring*")
+ (existing (get-buffer name))
+ (buffer (get-buffer-create name)))
+ (unless existing
+ (with-current-buffer buffer
+ (doctor-boring--initialize-buffer)))
+ (switch-to-buffer buffer)))
+
+(defun doctor-boring--live-message-p (message)
+ "Return non-nil when MESSAGE has live markers in the current buffer."
+ (and (markerp (doctor-boring--message-start message))
+ (markerp (doctor-boring--message-end message))
+ (eq (marker-buffer (doctor-boring--message-start message))
+ (current-buffer))
+ (eq (marker-buffer (doctor-boring--message-end message))
+ (current-buffer))))
+
+(defun doctor-boring--normalize-boundaries (&rest _ignored)
+ "Restore non-overlapping message boundaries after an edit."
+ (unless doctor-boring--normalizing-boundaries
+ (let ((doctor-boring--normalizing-boundaries t))
+ (setq doctor-boring--messages
+ (cl-remove-if-not #'doctor-boring--live-message-p
+ doctor-boring--messages))
+ (dolist (message doctor-boring--messages)
+ (when (< (marker-position (doctor-boring--message-end message))
+ (marker-position (doctor-boring--message-start message)))
+ (set-marker (doctor-boring--message-end message)
+ (doctor-boring--message-start message))))
+ (cl-loop for (message next) on doctor-boring--messages
+ while next
+ when (> (marker-position
+ (doctor-boring--message-end message))
+ (marker-position
+ (doctor-boring--message-start next)))
+ do (set-marker (doctor-boring--message-end message)
+ (doctor-boring--message-start next)))
+ (when (and doctor-boring--messages
+ (markerp doctor-boring--input-start)
+ (eq (marker-buffer doctor-boring--input-start)
+ (current-buffer)))
+ (let ((last (car (last doctor-boring--messages))))
+ (when (> (marker-position (doctor-boring--message-end last))
+ (marker-position doctor-boring--input-start))
+ (set-marker (doctor-boring--message-end last)
+ doctor-boring--input-start)))))))
+
+(defun doctor-boring--build-messages ()
+ "Build API messages from the current buffer's recorded message ranges."
+ (let ((messages
+ (list `((role . "system")
+ (content . ,doctor-boring-system-prompt)))))
+ (dolist (record doctor-boring--messages)
+ (when (doctor-boring--live-message-p record)
+ (let ((content
+ (string-trim
+ (buffer-substring-no-properties
+ (doctor-boring--message-start record)
+ (doctor-boring--message-end record)))))
+ (unless (string-empty-p content)
+ (setq messages
+ (nconc messages
+ (list
+ `((role . ,(symbol-name
+ (doctor-boring--message-role record)))
+ (content . ,content)))))))))
+ messages))
+
+(defun doctor-boring--return ()
+ "Insert a newline or submit when RET completes the current input."
+ (interactive)
+ (if (or (<= (point) (marker-position doctor-boring--input-start))
+ (/= (point) (point-max))
+ (not (eq (char-before) ?\n)))
+ (newline)
+ (doctor-boring--submit)))
+
+(defun doctor-boring--submit-immediately ()
+ "Submit the current input, or insert a newline while editing history."
+ (interactive)
+ (if (< (point) (marker-position doctor-boring--input-start))
+ (newline)
+ (doctor-boring--submit)))
+
+(defun doctor-boring--chat-completions-url ()
+ "Return the configured Chat Completions URL.
+Signal an error if the configured endpoint is empty."
+ (let* ((endpoint (string-trim doctor-boring-endpoint))
+ (base (replace-regexp-in-string "/+\\'" "" endpoint)))
+ (when (string-empty-p base)
+ (error "The Doctor Boring endpoint is empty"))
+ (concat base "/chat/completions")))
+
+(defun doctor-boring--request-headers ()
+ "Return headers for an API request without exposing an empty key."
+ (let ((headers '(("Content-Type" . "application/json")
+ ("Accept" . "application/json")))
+ (key (string-trim doctor-boring-api-key)))
+ (unless (string-empty-p key)
+ (setq headers
+ (append headers
+ `(("Authorization" . ,(concat "Bearer " key))))))
+ headers))
+
+(defun doctor-boring--serialize-request (messages)
+ "Serialize MESSAGES into an OpenAI-compatible request body."
+ (encode-coding-string
+ (json-serialize
+ `((model . ,doctor-boring-model)
+ (temperature . ,doctor-boring-temperature)
+ (messages . ,(vconcat messages))))
+ 'utf-8))
+
+(defun doctor-boring--submit ()
+ "Commit and asynchronously send the current input."
+ (unless doctor-boring--active-request
+ (let* ((start (marker-position doctor-boring--input-start))
+ (input (string-trim
+ (buffer-substring-no-properties start (point-max)))))
+ (if (string-empty-p input)
+ (let ((doctor-boring--normalizing-boundaries t))
+ (delete-region start (point-max))
+ (set-marker doctor-boring--input-start (point-max))
+ (goto-char (point-max)))
+ (let (record request messages)
+ (let ((doctor-boring--normalizing-boundaries t))
+ (delete-region start (point-max))
+ (goto-char start)
+ (setq record (doctor-boring--insert-message 'user input))
+ (setq doctor-boring--messages
+ (append doctor-boring--messages (list record)))
+ (doctor-boring--insert-separator record)
+ (set-marker doctor-boring--input-start (point-max))
+ (setq messages (doctor-boring--build-messages)))
+ (cl-incf doctor-boring--request-sequence)
+ (setq request
+ (make-doctor-boring--request
+ :id doctor-boring--request-sequence
+ :conversation-buffer (current-buffer)
+ :submitted-message record
+ :submitted-text input))
+ (setq doctor-boring--active-request request)
+ (setq buffer-read-only t)
+ (condition-case error-data
+ (let ((url (doctor-boring--chat-completions-url))
+ (data (doctor-boring--serialize-request messages)))
+ (doctor-boring--start-request request url data))
+ (error
+ (doctor-boring--complete-failure
+ request
+ "Configuration or request encoding failed."
+ (format "%S" error-data)))))))))
+
+(defun doctor-boring--start-request (request url data)
+ "Start REQUEST asynchronously against URL using serialized DATA."
+ (condition-case error-data
+ (progn
+ (setf (doctor-boring--request-timer request)
+ (run-at-time doctor-boring-request-timeout nil
+ #'doctor-boring--timeout request))
+ (let* ((url-request-method "POST")
+ (url-request-extra-headers
+ (doctor-boring--request-headers))
+ (url-request-data data)
+ (retrieval
+ (funcall doctor-boring--retrieve-function
+ url #'doctor-boring--url-callback
+ (list request) t t)))
+ (if (doctor-boring--request-active-p request)
+ (setf (doctor-boring--request-retrieval-buffer request)
+ retrieval)
+ (doctor-boring--dispose-retrieval retrieval))))
+ (error
+ (doctor-boring--complete-failure
+ request "Network request could not be started."
+ (format "%S" error-data)))))
+
+(defun doctor-boring--request-active-p (request)
+ "Return non-nil if REQUEST is the current live request."
+ (let ((buffer (doctor-boring--request-conversation-buffer request)))
+ (and (buffer-live-p buffer)
+ (not (doctor-boring--request-completed request))
+ (with-current-buffer buffer
+ (eq doctor-boring--active-request request)))))
+
+(defun doctor-boring--claim-request (request)
+ "Claim REQUEST for one terminal outcome and reject stale outcomes."
+ (when (doctor-boring--request-active-p request)
+ (with-current-buffer
+ (doctor-boring--request-conversation-buffer request)
+ (setq doctor-boring--active-request nil))
+ (setf (doctor-boring--request-completed request) t)
+ (when (timerp (doctor-boring--request-timer request))
+ (cancel-timer (doctor-boring--request-timer request)))
+ (setf (doctor-boring--request-timer request) nil)
+ t))
+
+(defun doctor-boring--response-body ()
+ "Return the current URL retrieval buffer's UTF-8 response body."
+ (unless url-http-end-of-headers
+ (error "Response has no HTTP header boundary"))
+ (let ((start (if (markerp url-http-end-of-headers)
+ (marker-position url-http-end-of-headers)
+ url-http-end-of-headers)))
+ (unless (and start (<= start (point-max)))
+ (error "Invalid HTTP header boundary"))
+ (let ((body (buffer-substring-no-properties start (point-max))))
+ (decode-coding-string
+ (if (multibyte-string-p body)
+ (encode-coding-string body 'raw-text)
+ body)
+ 'utf-8))))
+
+(defun doctor-boring--parse-response (body)
+ "Parse BODY and return a non-empty Chat Completions response string."
+ (let* ((parsed (json-parse-string body
+ :object-type 'plist
+ :array-type 'list))
+ (choices (and (listp parsed) (plist-get parsed :choices))))
+ (unless (and (listp choices) choices)
+ (error "Response has no choices"))
+ (let* ((choice (car choices))
+ (message (and (listp choice) (plist-get choice :message)))
+ (content (and (listp message) (plist-get message :content))))
+ (unless (listp message)
+ (error "Response choice has no message"))
+ (unless (stringp content)
+ (error "Response message content is not a string"))
+ (setq content (string-trim content))
+ (when (string-empty-p content)
+ (error "Response message content is empty"))
+ content)))
+
+(defun doctor-boring--url-callback (status request)
+ "Handle retrieval STATUS for REQUEST in the current response buffer."
+ (let ((retrieval (current-buffer))
+ response-body)
+ (unwind-protect
+ (when (doctor-boring--request-active-p request)
+ (condition-case error-data
+ (cond
+ ((plist-get status :error)
+ (doctor-boring--complete-failure
+ request "Network request failed."
+ (format "URL error: %S" (plist-get status :error))))
+ ((not (integerp url-http-response-status))
+ (doctor-boring--complete-failure
+ request "Network response was invalid."
+ "Missing HTTP response status"))
+ ((not (<= 200 url-http-response-status 299))
+ (let ((body (doctor-boring--response-body)))
+ (setq response-body body)
+ (doctor-boring--complete-failure
+ request "HTTP request failed."
+ (format "HTTP %d; body: %s"
+ url-http-response-status body))))
+ (t
+ (setq response-body (doctor-boring--response-body))
+ (doctor-boring--complete-success
+ request
+ (doctor-boring--parse-response
+ response-body))))
+ (error
+ (when (doctor-boring--request-active-p request)
+ (doctor-boring--complete-failure
+ request "The server response was malformed."
+ (if response-body
+ (format "Response handling error: %S; body: %s"
+ error-data response-body)
+ (format "Response handling error: %S"
+ error-data)))))))
+ (doctor-boring--dispose-retrieval retrieval))))
+
+(defun doctor-boring--prepare-success-rollback (request)
+ "Remove partial assistant state so claimed REQUEST can be rolled back."
+ (let ((buffer (doctor-boring--request-conversation-buffer request))
+ (submitted (doctor-boring--request-submitted-message request)))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (let ((tail (memq submitted doctor-boring--messages)))
+ (when tail
+ (mapc #'doctor-boring--detach-message (cdr tail))
+ (setq doctor-boring--messages
+ (cl-loop for message in doctor-boring--messages
+ collect message
+ until (eq message submitted)))))))))
+
+(defun doctor-boring--complete-success (request content)
+ "Complete REQUEST successfully with assistant CONTENT."
+ (when (doctor-boring--claim-request request)
+ (let ((buffer (doctor-boring--request-conversation-buffer request)))
+ (condition-case error-data
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t)
+ (doctor-boring--normalizing-boundaries t))
+ (goto-char (point-max))
+ (let ((record
+ (doctor-boring--insert-message 'assistant content)))
+ (setq doctor-boring--messages
+ (append doctor-boring--messages (list record)))
+ (doctor-boring--insert-separator record))
+ (set-marker doctor-boring--input-start (point-max))
+ (goto-char (point-max))
+ (setq buffer-read-only nil)))
+ (error
+ (doctor-boring--prepare-success-rollback request)
+ (doctor-boring--finish-failure
+ request "The response could not be recorded."
+ (format "Success completion error: %S" error-data)))))))
+
+(defun doctor-boring--finish-failure (request concise detail)
+ "Roll back claimed REQUEST, displaying CONCISE and logging DETAIL."
+ (message "Doctor Boring request %d failed: %s"
+ (doctor-boring--request-id request)
+ (doctor-boring--redact-api-key detail))
+ (let ((buffer (doctor-boring--request-conversation-buffer request))
+ (record (doctor-boring--request-submitted-message request))
+ (text (doctor-boring--request-submitted-text request)))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t)
+ (doctor-boring--normalizing-boundaries t))
+ (if (and (doctor-boring--live-message-p record)
+ (eq record (car (last doctor-boring--messages))))
+ (progn
+ (delete-region (doctor-boring--message-start record)
+ (point-max))
+ (setq doctor-boring--messages
+ (delq record doctor-boring--messages))
+ (set-marker (doctor-boring--message-start record) nil)
+ (set-marker (doctor-boring--message-end record) nil))
+ (goto-char (point-max)))
+ (goto-char (point-max))
+ (let ((error-start (point)))
+ (insert "[Doctor Boring error: " concise "]")
+ (add-text-properties
+ error-start (point) '(doctor-boring-local-error t)))
+ (insert "\n\n")
+ (if (markerp doctor-boring--input-start)
+ (set-marker doctor-boring--input-start (point))
+ (setq doctor-boring--input-start (copy-marker (point) nil)))
+ (insert text)
+ (goto-char (point-max))
+ (setq buffer-read-only nil))))))
+
+(defun doctor-boring--redact-api-key (detail)
+ "Return DETAIL with the configured API key redacted."
+ (let ((key (string-trim doctor-boring-api-key)))
+ (if (string-empty-p key)
+ detail
+ (replace-regexp-in-string
+ (regexp-quote key) "[REDACTED]" detail t t))))
+
+(defun doctor-boring--complete-failure (request concise detail)
+ "Claim and fail REQUEST, displaying CONCISE and logging DETAIL."
+ (when (doctor-boring--claim-request request)
+ (doctor-boring--finish-failure request concise detail)))
+
+(defun doctor-boring--timeout (request)
+ "Fail REQUEST if its asynchronous deadline has expired."
+ (when (doctor-boring--claim-request request)
+ (doctor-boring--dispose-retrieval
+ (doctor-boring--request-retrieval-buffer request))
+ (setf (doctor-boring--request-retrieval-buffer request) nil)
+ (doctor-boring--finish-failure
+ request "The request timed out." "Request deadline expired")))
+
+(defun doctor-boring--dispose-retrieval (buffer)
+ "Stop the process belonging to BUFFER and kill BUFFER when it is live."
+ (when (buffer-live-p buffer)
+ (let ((process (get-buffer-process buffer)))
+ (when (process-live-p process)
+ (set-process-query-on-exit-flag process nil)
+ (delete-process process)))
+ (let ((kill-buffer-query-functions nil))
+ (kill-buffer buffer))))
+
+(defun doctor-boring--detach-message (message)
+ "Detach both markers owned by MESSAGE."
+ (when (markerp (doctor-boring--message-start message))
+ (set-marker (doctor-boring--message-start message) nil))
+ (when (markerp (doctor-boring--message-end message))
+ (set-marker (doctor-boring--message-end message) nil)))
+
+(defun doctor-boring--kill-buffer ()
+ "Cancel the current request and detach conversation metadata."
+ (when doctor-boring--active-request
+ (let ((request doctor-boring--active-request))
+ (setq doctor-boring--active-request nil)
+ (setf (doctor-boring--request-completed request) t)
+ (when (timerp (doctor-boring--request-timer request))
+ (cancel-timer (doctor-boring--request-timer request)))
+ (setf (doctor-boring--request-timer request) nil)
+ (let ((retrieval
+ (doctor-boring--request-retrieval-buffer request)))
+ (when (and (buffer-live-p retrieval)
+ (not (eq retrieval (current-buffer))))
+ (doctor-boring--dispose-retrieval retrieval)))))
+ (mapc #'doctor-boring--detach-message doctor-boring--messages)
+ (when (markerp doctor-boring--input-start)
+ (set-marker doctor-boring--input-start nil)))
+
+(provide 'doctor-boring)
+;;; doctor-boring.el ends here