;;; 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