;; -*- lexical-binding: t -*- (require 'cl-lib) (require 'url-parse) (require 'network-stream) (require 'project) (require 'pulse) (require 'subr-x) (defgroup my-llm nil "Streaming LLM chat buffer with tools." :group 'tools) (defcustom my-llm-endpoint "http://127.0.0.1:8000/v1/chat/completions" "OpenAI-compatible chat completions endpoint." :type 'string :group 'my-llm) (defcustom my-llm-model "qwen3.8-27b-fp8" "Model name to send to `my-llm-endpoint'." :type 'string :group 'my-llm) (defcustom my-llm-provider 'local "Backend to send requests to. `local' posts to `my-llm-endpoint' in the OpenAI chat completions format. `chatgpt' posts to `my-llm-chatgpt-endpoint' in the Responses format, using the ChatGPT OAuth credentials pi keeps in `my-llm-pi-auth-file'." :type '(choice (const :tag "OpenAI-compatible endpoint" local) (const :tag "ChatGPT (pi's openai-codex login)" chatgpt)) :group 'my-llm) (defcustom my-llm-chatgpt-model "gpt-5.6-sol" "Model name for `chatgpt' requests." :type 'string :group 'my-llm) (defcustom my-llm-chatgpt-reasoning-effort "low" "Reasoning effort for `chatgpt' requests. The default is `low'. Nil leaves the effort unspecified so the backend chooses its default. Model support varies; the usual levels run from `minimal' through `xhigh'." :type '(choice (const :tag "Backend default" nil) (const :tag "Minimal" "minimal") (const :tag "Low" "low") (const :tag "Medium" "medium") (const :tag "High" "high") (const :tag "Extra high" "xhigh")) :group 'my-llm) (defcustom my-llm-chatgpt-endpoint "https://chatgpt.com/backend-api/codex/responses" "ChatGPT Codex Responses endpoint." :type 'string :group 'my-llm) (defcustom my-llm-pi-auth-file (expand-file-name "~/.pi/agent/auth.json") "pi's credential store, read for the ChatGPT OAuth token." :type 'file :group 'my-llm) (defcustom my-llm-pi-command "pi" "pi executable, run to refresh an expired ChatGPT token." :type 'string :group 'my-llm) (defcustom my-llm-system-prompt "You are a coding assistant working inside the user's Emacs. Use read_file to inspect files and read_buffer to read open buffers, including unsaved edits. Reads are displayed and their returned region is highlighted in a non-chat window, opening one if necessary. write_file creates or overwrites a file; edit_buffer replaces exact text in the Emacs buffer visiting an existing file. Both edits are displayed, highlighted, undoable, and saved. Read before editing, and prefer edit_buffer over write_file for existing files. Use bash to execute shell commands in the project (or another explicitly named working directory), including tests and formatters. Display tool targets in a window that is not showing the my-llm chat buffer, reusing one when possible and opening one when necessary; do not select it. list_files lists project files and find_files finds files by glob or basename substring. list_buffers and list_windows report what is open and visible; get_selection reports the selection and point from which the prompt was sent. When the user refers to \"this\", \"here\", or what they are looking at, use get_selection and list_windows first." "System prompt." :type 'string :group 'my-llm) (defcustom my-llm-api-key nil "Bearer token for the endpoint, or nil for no Authorization header." :type '(choice (const :tag "None" nil) string) :group 'my-llm) (defcustom my-llm-tool-result-limit 100000 "Maximum characters of a tool result sent to the model." :type 'integer :group 'my-llm) (defcustom my-llm-bash-command "bash" "Bash executable used by the `bash' tool." :type 'string :group 'my-llm) (defcustom my-llm-bash-timeout 120 "Maximum number of seconds the `bash' tool may run." :type 'integer :group 'my-llm) (defconst my-llm-prompt-marker "\u276f " "Prefix of a user message line in the chat buffer.") (defconst my-llm-reply-marker "\u23fa " "Prefix of an assistant message line in the chat buffer.") (defconst my-llm--ui-prefixes '("\u2699 " "\u2502 " "\u26a0 ") "Line prefixes reserved for tool and notice chrome. Lines starting with one of these are shown to the user but are not part of the conversation sent to the model.") (defvar-local my-llm--messages nil "Conversation sent to the model, rebuilt from the chat buffer on each send.") (defvar-local my-llm--state nil "Streaming state for the in-flight request in this buffer.") (defvar-local my-llm--proc nil "Live network process, if any.") (defvar-local my-llm--busy nil "Non-nil while a request is in flight.") (defvar-local my-llm--last-note nil "Short description of how the last request ended, such as \"done\".") (defvar-local my-llm--last-stopped nil "Time the last request ended, for the header line notice.") (defvar-local my-llm--request-start nil "Time the in-flight request was sent, for the header line.") (defvar-local my-llm--origin-root nil "Project root of the buffer the current prompt came from.") (defvar-local my-llm--origin-buffer nil "Buffer the current prompt was sent from, if it is not a chat buffer.") (defvar-local my-llm--origin-selection nil "Region text selected when the current prompt was sent, if any.") (defvar-local my-llm--text-start nil "Buffer position where the current assistant message starts.") (defvar-local my-llm--reply-pos nil "End of the buffer before the current reply marker was inserted.") (defvar-local my-llm--spinner-timer nil "Timer animating the waiting indicator, while a request is in flight.") (defvar-local my-llm--spinner-index 0 "Index into `my-llm--spinner-frames' of the waiting indicator.") (defconst my-llm--spinner-frames ["\u280b" "\u2819" "\u2839" "\u2838" "\u283c" "\u2834" "\u2826" "\u2827" "\u2807" "\u280f"] "Braille frames for the waiting indicator.") (defface my-llm-prompt-face '((t :inherit font-lock-keyword-face)) "User prompt." :group 'my-llm) (defface my-llm-tool-face '((t :inherit font-lock-function-name-face)) "Tool call." :group 'my-llm) (defface my-llm-dim-face '((t :inherit shadow)) "Tool output and notices." :group 'my-llm) (defface my-llm-error-face '((t :inherit error)) "Errors." :group 'my-llm) (defface my-llm-progress-face '((t :inherit font-lock-comment-face)) "The waiting indicator shown while the model is responding." :group 'my-llm) (defface my-llm-reply-face '((t :inherit font-lock-doc-face)) "Assistant reply marker." :group 'my-llm) ;;; Tools (defun my-llm--root () "Project root of the buffer the current prompt came from." (or my-llm--origin-root (when-let* ((project (project-current nil))) (expand-file-name (project-root project))) (expand-file-name default-directory))) (defun my-llm--arg-int (args key default) "Integer argument KEY in ARGS, or DEFAULT if absent, null or not an integer." (let ((value (alist-get key args))) (if (integerp value) value default))) (defun my-llm--arg-path (args) "Absolute path from the \"path\" argument in ARGS, relative to the project root." (let ((path (alist-get 'path args))) (unless (and (stringp path) (not (string-empty-p (string-trim path)))) (error "path is required")) (expand-file-name path (my-llm--root)))) (defun my-llm--truncate (text) "Clip TEXT to `my-llm-tool-result-limit' characters." (if (> (length text) my-llm-tool-result-limit) (concat (substring text 0 my-llm-tool-result-limit) (format "\n... truncated at %d chars" my-llm-tool-result-limit)) text)) (defun my-llm--slice (from to) "Text of the accessible buffer between lines FROM and TO, both inclusive." (save-excursion (goto-char (point-min)) (forward-line (1- from)) (let ((beg (point))) (forward-line (1+ (- to from))) (buffer-substring-no-properties beg (point))))) (defun my-llm--file-text (path) "Current text of PATH, preferring the buffer visiting it." (if-let* ((buf (find-buffer-visiting path))) (with-current-buffer buf (save-restriction (widen) (buffer-substring-no-properties (point-min) (point-max)))) (with-temp-buffer (insert-file-contents path) (buffer-substring-no-properties (point-min) (point-max))))) (defun my-llm--save-file-buffer () "Save the current file-visiting buffer, or signal if it remains modified. Tool edits use this instead of merely requesting a save, so a successful tool result guarantees that the edited buffer was actually saved." (unless buffer-file-name (error "buffer %s is not visiting a file" (buffer-name))) (save-buffer) (when (buffer-modified-p) (error "saving %s did not clear its modified state" buffer-file-name))) (defun my-llm--write-file (path text) "Store TEXT as the contents of PATH. If a buffer visits PATH, replace its contents instead of writing the file directly, so the change is undoable, then save the buffer. Missing parent directories are created." (if-let* ((buf (find-buffer-visiting path))) (with-current-buffer buf (let ((inhibit-read-only t) (origin (point))) (save-restriction (widen) (erase-buffer) (insert text)) (goto-char (min origin (point-max))) (my-llm--save-file-buffer))) (let ((dir (file-name-directory path))) (unless (file-directory-p dir) (make-directory dir t))) (with-temp-buffer (when (file-exists-p path) (insert-file-contents path)) (erase-buffer) (insert text) (let ((coding-system-for-write (or buffer-file-coding-system 'utf-8))) (write-region (point-min) (point-max) path nil 'silent))))) (defun my-llm--chat-buffer-p (buf) "Non-nil when BUF is a my-llm chat buffer." (and (buffer-live-p buf) (with-current-buffer buf (derived-mode-p 'my-llm-mode)))) (defun my-llm--display-window (buf) "Return a non-chat window suitable for displaying BUF. Prefer a non-chat window already showing BUF, then reuse another non-chat window. If every existing window is a chat window, open a new window (or, if necessary, a new frame) rather than failing merely because BUF was not already visible. Do not select the returned window." (or (seq-find (lambda (win) (not (my-llm--chat-buffer-p (window-buffer win)))) (get-buffer-window-list buf nil t)) (seq-find (lambda (win) (not (my-llm--chat-buffer-p (window-buffer win)))) (window-list (selected-frame) 'no-minibuffer)) (seq-find (lambda (win) (not (my-llm--chat-buffer-p (window-buffer win)))) (apply #'append (mapcar (lambda (frame) (window-list frame 'no-minibuffer)) (frame-list)))) (display-buffer buf '((display-buffer-pop-up-window) (inhibit-same-window . t))) (display-buffer buf '((display-buffer-pop-up-frame) (inhibit-same-window . t))) (error "unable to open a window to display %s" (buffer-name buf)))) (defun my-llm--show-region (buf start end) "Display and momentarily highlight BUF from START to END. Reuse a non-chat window when possible, otherwise open one, without selecting it." (let ((win (my-llm--display-window buf))) (set-window-buffer win buf) (with-current-buffer buf (save-restriction (widen) (setq start (max (point-min) (min start (point-max)))) (setq end (max start (min end (point-max)))) (set-window-point win start) (save-excursion (goto-char start) (forward-line (- (/ (window-body-height win) 2))) (set-window-start win (line-beginning-position))) ;; A zero-width edit still gets a visible one-character pulse where ;; possible; reads and non-empty replacements highlight their extent. (let ((pulse-end (if (> end start) end (min (1+ start) (point-max))))) (when (> pulse-end start) (pulse-momentary-highlight-region start pulse-end))))))) (defun my-llm--line-region (from to) "Return buffer positions covering lines FROM through TO, inclusive." (save-excursion (goto-char (point-min)) (forward-line (1- from)) (let ((start (point))) (forward-line (1+ (- to from))) (cons start (point))))) (defun my-llm--line-count (text) "Number of lines in TEXT." (length (split-string text "\n"))) (defun my-llm--count-occurrences (text needle) "Number of non-overlapping occurrences of NEEDLE in TEXT." (let ((pos 0) (count 0)) (while (setq pos (string-search needle text pos)) (setq count (1+ count)) (setq pos (+ pos (length needle)))) count)) (defun my-llm--replace-first (text old new) "TEXT with the first literal occurrence of OLD replaced by NEW." (let ((pos (string-search old text))) (concat (substring text 0 pos) new (substring text (+ pos (length old)))))) (defun my-llm--replace-all (text old new) "TEXT with every literal occurrence of OLD replaced by NEW." (replace-regexp-in-string (regexp-quote old) (lambda (_match) new) text t t)) (defun my-llm--describe-buffer (buf) "One-line description of BUF: name, major mode, file and flags." (format "%s [%s]%s%s%s%s" (buffer-name buf) (buffer-local-value 'major-mode buf) (if-let* ((file (buffer-file-name buf))) (format " %s" file) "") (if (buffer-modified-p buf) " modified" "") (if (buffer-local-value 'buffer-read-only buf) " read-only" "") (if (with-current-buffer buf (buffer-narrowed-p)) " narrowed" ""))) (defun my-llm--find-buffer (name) "Return the buffer called NAME, or the prompt's origin buffer when NAME is nil. NAME may also be the file a buffer visits, or a unique substring of a buffer name; an unknown or ambiguous NAME signals an error listing candidates." (let ((name (and name (string-trim name)))) (cond ((or (null name) (string-empty-p name)) (or (and (buffer-live-p my-llm--origin-buffer) my-llm--origin-buffer) (error "no origin buffer; name a buffer explicitly"))) ((get-buffer name)) ((find-buffer-visiting (expand-file-name name (my-llm--root)))) (t (let* ((matches (seq-filter (lambda (buf) (string-match-p (regexp-quote name) (buffer-name buf))) (buffer-list))) (visible (seq-remove (lambda (buf) (string-prefix-p " " (buffer-name buf))) matches)) (matches (or visible matches))) (cond ((null matches) (error "no buffer matching %S" name)) ((cdr matches) (error "buffer name %S is ambiguous: %s" name (mapconcat #'buffer-name matches ", "))) (t (car matches)))))))) (defun my-llm--arg-directory (args) "Directory named by optional path in ARGS, defaulting to the project root." (let ((path (alist-get 'path args))) (expand-file-name (if (and (stringp path) (not (string-empty-p (string-trim path)))) path ".") (my-llm--root)))) (defun my-llm--display-path (path) "Readable name for PATH, relative to the prompt's project when possible." (let ((root (file-name-as-directory (expand-file-name (my-llm--root)))) (path (expand-file-name path))) (if (file-in-directory-p path root) (file-relative-name path root) path))) (defun my-llm--collect-files (directory predicate limit recursive) "Collect files below DIRECTORY accepted by PREDICATE. Return (FILES . TRUNCATED), stopping after LIMIT matches. Descend recursively when RECURSIVE is non-nil, but do not follow directory symlinks or enter VCS metadata directories." (let ((files nil) (truncated nil) (stop nil)) (cl-labels ((add-file (file) (when (funcall predicate file) (if (>= (length files) limit) (setq truncated t stop t) (push file files)))) (walk (dir) (condition-case nil (dolist (entry (directory-files dir t directory-files-no-dot-files-regexp)) (unless stop (cond ((and recursive (file-directory-p entry) (not (file-symlink-p entry)) (not (member (file-name-nondirectory entry) '(".git" ".hg" ".svn")))) (walk entry)) ((file-regular-p entry) (add-file entry))))) (file-error nil)))) (walk directory)) (cons (nreverse files) truncated))) (defun my-llm--format-file-results (heading result) "Format file collection RESULT under HEADING." (let ((files (car result)) (truncated (cdr result))) (my-llm--truncate (concat heading "\n" (if files (mapconcat #'my-llm--display-path files "\n") "no matching files") (if truncated "\n... result limit reached" ""))))) (defun my-llm-tool-list-files (args) "List files in a directory. ARGS has path, recursive and limit." (let* ((directory (my-llm--arg-directory args)) (recursive (eq t (alist-get 'recursive args))) (limit (max 1 (min 10000 (my-llm--arg-int args 'limit 1000))))) (cond ((not (file-exists-p directory)) (format "ERROR: no such directory: %s" directory)) ((not (file-directory-p directory)) (format "ERROR: not a directory: %s" directory)) ((not (file-readable-p directory)) (format "ERROR: not readable: %s" directory)) (t (my-llm--format-file-results (format "Files in %s%s:" directory (if recursive " (recursive)" "")) (my-llm--collect-files directory (lambda (_file) t) limit recursive)))))) (defun my-llm-tool-find-files (args) "Find files recursively by substring or glob. ARGS has query, path and limit." (let* ((query (alist-get 'query args)) (directory (my-llm--arg-directory args)) (limit (max 1 (min 10000 (my-llm--arg-int args 'limit 1000)))) (glob (eq t (alist-get 'glob args)))) (cond ((not (and (stringp query) (not (string-empty-p query)))) "ERROR: query is required") ((not (file-exists-p directory)) (format "ERROR: no such directory: %s" directory)) ((not (file-directory-p directory)) (format "ERROR: not a directory: %s" directory)) ((not (file-readable-p directory)) (format "ERROR: not readable: %s" directory)) (t (let ((regexp (and glob (wildcard-to-regexp query)))) (my-llm--format-file-results (format "Files in %s matching %S%s:" directory query (if glob " as a glob" "")) (my-llm--collect-files directory (lambda (file) (let ((relative (file-relative-name file directory))) (if regexp (string-match-p regexp relative) (string-search (downcase query) (downcase relative))))) limit t))))))) (defun my-llm-tool-read-file (args) "Read and display a file. ARGS has path, start_line and end_line." (let* ((path (my-llm--arg-path args)) (start (my-llm--arg-int args 'start_line 1)) (end (my-llm--arg-int args 'end_line nil))) (cond ((not (file-exists-p path)) (format "ERROR: no such file: %s" path)) ((not (file-regular-p path)) (format "ERROR: not a regular file: %s" path)) ((not (file-readable-p path)) (format "ERROR: not readable: %s" path)) (t (let ((buf (or (find-buffer-visiting path) (find-file-noselect path)))) (with-current-buffer buf (save-restriction (widen) (let* ((last (line-number-at-pos (point-max))) (from (max 1 (min start last))) (to (max from (min (or end last) last))) (region (my-llm--line-region from to)) (result (my-llm--truncate (concat (format "%s (lines %d-%d of %d)\n" path from to last) (my-llm--slice from to))))) (my-llm--show-region buf (car region) (cdr region)) result)))))))) (defun my-llm-tool-read-buffer (args) "Read and display an open buffer. ARGS has name, start_line and end_line. Without a name, read the buffer from which the current prompt was sent." (let* ((buf (my-llm--find-buffer (alist-get 'name args))) (start (my-llm--arg-int args 'start_line 1)) (end (my-llm--arg-int args 'end_line nil))) (with-current-buffer buf (save-restriction (widen) (let* ((last (line-number-at-pos (point-max))) (from (max 1 (min start last))) (to (max from (min (or end last) last))) (region (my-llm--line-region from to)) (result (my-llm--truncate (concat (format "%s (lines %d-%d of %d)\n" (my-llm--describe-buffer buf) from to last) (my-llm--slice from to))))) (my-llm--show-region buf (car region) (cdr region)) result))))) (defun my-llm-tool-list-buffers (args) "List the user's buffers, most recently used first. ARGS may contain all, which also lists hidden buffers." (let ((all (eq t (alist-get 'all args))) (rows nil)) (dolist (buf (buffer-list)) (let ((name (buffer-name buf))) (when (or all (not (string-prefix-p " " name))) (let ((windows (length (get-buffer-window-list buf nil t)))) (push (format "%s %d lines%s" (my-llm--describe-buffer buf) (with-current-buffer buf (line-number-at-pos (point-max))) (cond ((= windows 0) "") ((= windows 1) " in 1 window") (t (format " in %d windows" windows)))) rows))))) (if rows (concat (format "%d buffers, most recently used first:\n" (length rows)) (mapconcat #'identity (nreverse rows) "\n")) "no buffers"))) (defun my-llm-tool-list-windows (_args) "List the windows of every frame: what they show and where point is." (let ((rows nil)) (dolist (frame (frame-list)) (dolist (win (window-list frame 0)) (let ((selected (eq win (frame-selected-window frame))) (buf (window-buffer win))) (with-current-buffer buf (push (format "frame %s%s%s: %s -- point line %d of %d, showing lines %d-%d, %d columns x %d rows%s" (or (frame-parameter frame 'name) "?") (if (eq frame (selected-frame)) ", current frame" "") (if selected ", selected window" "") (my-llm--describe-buffer buf) (line-number-at-pos (window-point win) t) (line-number-at-pos (point-max) t) (line-number-at-pos (window-start win) t) (line-number-at-pos (or (window-end win t) (point-max)) t) (window-body-width win) (window-body-height win) (if (window-dedicated-p win) ", dedicated" "")) rows))))) (if rows (mapconcat #'identity (nreverse rows) "\n") "no windows"))) (defun my-llm-tool-get-selection (_args) "Report the user's selection and cursor position." (let ((buf (and (buffer-live-p my-llm--origin-buffer) my-llm--origin-buffer))) (concat (if (null buf) "The prompt was sent from the chat buffer itself; no origin buffer.\n" (format "Prompt sent from %s.\n" (with-current-buffer buf (my-llm--describe-buffer buf)))) (cond ((and my-llm--origin-selection (not (string-empty-p (string-trim my-llm--origin-selection)))) (format "Selection when the prompt was sent (%d chars):\n%s\n" (length my-llm--origin-selection) my-llm--origin-selection)) (t "No selection was active when the prompt was sent.\n")) (when buf (with-current-buffer buf (format "Point is now at line %d, column %d:\n%s\n" (line-number-at-pos) (current-column) (buffer-substring-no-properties (line-beginning-position) (line-end-position)))))))) (defun my-llm-tool-bash (args) "Run a Bash command and return its combined output. ARGS has command and an optional working_directory. The command is killed when `my-llm-bash-timeout' expires." (let* ((command (alist-get 'command args)) (directory-arg (alist-get 'working_directory args)) (directory (expand-file-name (if (and (stringp directory-arg) (not (string-empty-p (string-trim directory-arg)))) directory-arg ".") (my-llm--root)))) (cond ((not (and (stringp command) (not (string-empty-p (string-trim command))))) "ERROR: command is required") ((not (file-directory-p directory)) (format "ERROR: not a directory: %s" directory)) ((not (file-accessible-directory-p directory)) (format "ERROR: directory is not accessible: %s" directory)) ((not (executable-find my-llm-bash-command)) (format "ERROR: `%s' is not in `exec-path'" my-llm-bash-command)) (t (with-temp-buffer (let* ((default-directory (file-name-as-directory directory)) (stderr (generate-new-buffer " *my-llm bash stderr*")) (process (make-process :name "my-llm-bash" :buffer (current-buffer) :stderr stderr :command (list my-llm-bash-command "-lc" command) :connection-type 'pipe :noquery t)) (deadline (+ (float-time) (max 1 my-llm-bash-timeout))) timed-out) (unwind-protect (progn (while (and (process-live-p process) (< (float-time) deadline)) (accept-process-output process 0.1)) (when (process-live-p process) (setq timed-out t) (delete-process process)) (accept-process-output process 0.05) (let* ((stdout (buffer-substring-no-properties (point-min) (point-max))) (stderr-text (with-current-buffer stderr (buffer-substring-no-properties (point-min) (point-max)))) (output (concat stdout stderr-text)) (status (unless timed-out (process-exit-status process)))) (my-llm--truncate (concat (cond (timed-out (format "Command timed out after %d seconds" my-llm-bash-timeout)) ((zerop status) (format "Command exited with status 0")) (t (format "Command exited with status %d" status))) (format "\nWorking directory: %s" directory) (unless (string-empty-p output) (concat "\n" output)))))) (when (process-live-p process) (delete-process process)) (kill-buffer stderr)))))))) (defun my-llm-tool-write-file (args) "Write a file. ARGS is an alist with path, content and overwrite." (let* ((path (my-llm--arg-path args)) (content (alist-get 'content args)) (overwrite (eq t (alist-get 'overwrite args))) (buf (find-buffer-visiting path)) (dirty (and buf (buffer-modified-p buf)))) (cond ((not (stringp content)) "ERROR: content must be a string") ((file-directory-p path) (format "ERROR: %s is a directory" path)) ((and (file-exists-p path) (not (file-writable-p path))) (format "ERROR: not writable: %s" path)) ((and dirty (not overwrite)) (format "ERROR: %s has unsaved changes; set overwrite to discard them" (buffer-name buf))) (t (my-llm--write-file path content) (let ((shown (or (find-buffer-visiting path) (find-file-noselect path)))) (with-current-buffer shown (save-restriction (widen) (my-llm--show-region shown (point-min) (point-max))))) (concat (format "Wrote %s (%d chars, %d lines)." path (length content) (my-llm--line-count content)) (if dirty "\nWARNING: discarded the buffer's unsaved changes." "")))))) (defun my-llm-tool-edit-buffer (args) "Replace text in the buffer visiting a file and save it. ARGS is an alist with path, old_string, new_string and replace_all." (let* ((path (my-llm--arg-path args)) (old (alist-get 'old_string args)) (new (alist-get 'new_string args)) (all (eq t (alist-get 'replace_all args))) (existing (find-buffer-visiting path)) (dirty (and existing (buffer-modified-p existing)))) (cond ((not (stringp old)) "ERROR: old_string is required") ((string-empty-p old) "ERROR: old_string must not be empty") ((not (stringp new)) "ERROR: new_string must be a string") ((file-directory-p path) (format "ERROR: %s is a directory" path)) ((not (file-exists-p path)) (format "ERROR: no such file: %s (use write_file to create it)" path)) ((not (file-writable-p path)) (format "ERROR: not writable: %s" path)) (t (let ((buf (or existing (find-file-noselect path)))) (with-current-buffer buf (save-restriction (widen) (let ((count (my-llm--count-occurrences (buffer-substring-no-properties (point-min) (point-max)) old))) (cond ((= count 0) (format "ERROR: old_string not found in %s" path)) ((and (> count 1) (not all)) (format "ERROR: old_string occurs %d times in %s; add context to make it unique, or set replace_all" count path)) (t (let (start) ;; Edit the actual file-visiting buffer rather than replacing ;; all of its text, preserving useful buffer state and undo. (atomic-change-group (save-excursion (goto-char (point-min)) (while (search-forward old nil t) (unless start (setq start (match-beginning 0))) (replace-match new t t) (unless all (goto-char (point-max)))))) (my-llm--save-file-buffer) (my-llm--show-region buf start (+ start (length new)))) (concat (format "Edited buffer %s (%s): replaced %d occurrence%s and saved it." (buffer-name buf) path count (if (= count 1) "" "s")) (if dirty "\nSaved the buffer's previous unsaved changes too." "")))))))))))) (defconst my-llm-tools (vector `((type . "function") (function (name . "list_files") (description . "List regular files in a directory relative to the project root. By default lists only the directory itself; set recursive to descend. VCS metadata directories and directory symlinks are skipped.") (parameters (type . "object") (properties (path . ((type . "string") (description . "Directory to list, absolute or relative to the project root. Optional; defaults to the project root."))) (recursive . ((type . "boolean") (description . "Recursively list files below the directory. Optional; defaults to false."))) (limit . ((type . "integer") (description . "Maximum number of files to return. Optional; defaults to 1000 and is capped at 10000."))))))) `((type . "function") (function (name . "find_files") (description . "Recursively find regular files below a directory. The query is matched case-insensitively as a substring of each relative path, or as a glob when glob is true. VCS metadata directories and directory symlinks are skipped.") (parameters (type . "object") (properties (query . ((type . "string") (description . "Filename or relative-path substring, or a glob such as **/*.el when glob is true."))) (path . ((type . "string") (description . "Directory to search, absolute or relative to the project root. Optional; defaults to the project root."))) (glob . ((type . "boolean") (description . "Interpret query as an Emacs wildcard glob rather than a case-insensitive substring. Optional."))) (limit . ((type . "integer") (description . "Maximum number of files to return. Optional; defaults to 1000 and is capped at 10000.")))) (required . ["query"])))) `((type . "function") (function (name . "read_file") (description . "Read a text file and display the returned region in an existing non-chat Emacs window, highlighting it momentarily. Returns the file content with an absolute-path and line-range header. Use start_line/end_line for a slice.") (parameters (type . "object") (properties (path . ((type . "string") (description . "Path to the file, absolute or relative to the project root."))) (start_line . ((type . "integer") (description . "First line to return, 1-indexed. Optional."))) (end_line . ((type . "integer") (description . "Last line to return, inclusive. Optional.")))) (required . ["path"])))) `((type . "function") (function (name . "read_buffer") (description . "Read an open Emacs buffer, including unsaved edits, and display the returned region in an existing non-chat window with a momentary highlight. Defaults to the prompt's origin buffer. Returns a buffer header and the requested lines.") (parameters (type . "object") (properties (name . ((type . "string") (description . "Buffer name, the file it visits, or a unique substring of its name. Optional; defaults to the buffer the prompt was sent from."))) (start_line . ((type . "integer") (description . "First line to return, 1-indexed. Optional."))) (end_line . ((type . "integer") (description . "Last line to return, inclusive. Optional."))))))) `((type . "function") (function (name . "list_buffers") (description . "List the user's open buffers, most recently used first, with major mode, file, line count, modified flag and how many windows show each one. Hidden buffers are omitted unless all is true.") (parameters (type . "object") (properties (all . ((type . "boolean") (description . "Also list hidden internal buffers whose names start with a space. Optional."))))))) `((type . "function") (function (name . "list_windows") (description . "List every window of every frame: the frame, whether the window is selected, the buffer it shows, where point is, which lines are visible and how big the window is. Use it to see what the user is looking at right now.") (parameters (type . "object")))) `((type . "function") (function (name . "get_selection") (description . "Report the user's selection and cursor context: the buffer the prompt was sent from, the text selected when it was sent, and the line point is on now. Call this when the user says \"this\", \"here\" or asks about what they are looking at.") (parameters (type . "object")))) `((type . "function") (function (name . "write_file") (description . "Create a file or overwrite it with new content, then display and highlight it in an existing non-chat window. Prefer edit_buffer for existing files, and read before overwriting. A visiting buffer is replaced and saved so the change is undoable; unsaved changes require overwrite=true.") (parameters (type . "object") (properties (path . ((type . "string") (description . "Path to the file, absolute or relative to the project root."))) (content . ((type . "string") (description . "Full new contents of the file."))) (overwrite . ((type . "boolean") (description . "Overwrite even if a buffer visiting the file has unsaved changes. Optional.")))) (required . ["path" "content"])))) `((type . "function") (function (name . "edit_buffer") (description . "Replace exact text in the Emacs buffer visiting an existing file and save it. Display the buffer in an existing non-chat window, scroll to the change, and highlight it momentarily without selecting or rearranging windows. old_string must match exactly and be unique unless replace_all is true; add context when needed. Prefer this over write_file for existing files.") (parameters (type . "object") (properties (path . ((type . "string") (description . "Path to the file, absolute or relative to the project root."))) (old_string . ((type . "string") (description . "Exact text to replace, including indentation."))) (new_string . ((type . "string") (description . "Replacement text; an empty string deletes old_string."))) (replace_all . ((type . "boolean") (description . "Replace every occurrence of old_string, not just a unique one. Optional.")))) (required . ["path" "old_string" "new_string"]))))) "Tool schemas advertised to the model.") (defconst my-llm-tool-handlers '(("list_files" . my-llm-tool-list-files) ("find_files" . my-llm-tool-find-files) ("read_file" . my-llm-tool-read-file) ("read_buffer" . my-llm-tool-read-buffer) ("list_buffers" . my-llm-tool-list-buffers) ("list_windows" . my-llm-tool-list-windows) ("get_selection" . my-llm-tool-get-selection) ("write_file" . my-llm-tool-write-file) ("edit_buffer" . my-llm-tool-edit-buffer)) "Maps tool name to a function taking an alist of arguments.") ;;; ChatGPT credentials (defconst my-llm--chatgpt-provider 'openai-codex "Key pi stores the ChatGPT OAuth credentials under in `my-llm-pi-auth-file'.") (defun my-llm--now-ms () "Current time in milliseconds since the epoch." (floor (* 1000 (float-time)))) (defun my-llm--pi-auth-entry (name) "The credential entry NAME in `my-llm-pi-auth-file'." (with-temp-buffer (insert-file-contents my-llm-pi-auth-file) (alist-get name (json-parse-string (buffer-string) :object-type 'alist)))) (defun my-llm--chatgpt-token-stale-p (entry) "Non-nil when ENTRY's ChatGPT access token is missing or expires within a minute." (let ((expires (alist-get 'expires entry))) (or (not (numberp expires)) (< expires (+ (my-llm--now-ms) 60000))))) (defun my-llm--refresh-chatgpt-token () "Refresh the ChatGPT token by running pi, which owns the rotation. pi writes the new token back to `my-llm-pi-auth-file'." (unless (executable-find my-llm-pi-command) (error "ChatGPT token expired, and `%s' is not in `exec-path'; run pi to log in" my-llm-pi-command)) (with-temp-buffer (let ((status (call-process my-llm-pi-command nil t nil "auth" "print-bearer-token" "--provider" (symbol-name my-llm--chatgpt-provider) "--min-expiry" "5m"))) (unless (and (integerp status) (zerop status)) (error "`%s auth print-bearer-token' failed: %s" my-llm-pi-command (string-trim (buffer-string))))))) (defun my-llm--chatgpt-credentials () "Return (ACCESS-TOKEN . ACCOUNT-ID) for the ChatGPT backend. Credentials are read from pi's `my-llm-pi-auth-file'; an expired token is refreshed through pi first, so both keep the same rotation." (unless (file-readable-p my-llm-pi-auth-file) (error "No ChatGPT credentials at %s; run pi to log in" my-llm-pi-auth-file)) (let ((entry (my-llm--pi-auth-entry my-llm--chatgpt-provider))) (unless entry (error "No %s credentials in %s; run pi to log in" my-llm--chatgpt-provider my-llm-pi-auth-file)) (when (my-llm--chatgpt-token-stale-p entry) (my-llm--refresh-chatgpt-token) (setq entry (my-llm--pi-auth-entry my-llm--chatgpt-provider))) (let ((access (alist-get 'access entry)) (account (alist-get 'accountId entry))) (unless (and (stringp access) (not (string-empty-p access))) (error "No %s access token in %s" my-llm--chatgpt-provider my-llm-pi-auth-file)) (unless (and (stringp account) (not (string-empty-p account))) (error "No %s accountId in %s; run pi to log in" my-llm--chatgpt-provider my-llm-pi-auth-file)) (cons access account)))) ;;; Transport (defun my-llm--accumulate-tool-call (state fragment) "Merge a streamed tool_call FRAGMENT into STATE's accumulator." (let* ((index (or (alist-get 'index fragment) 0)) (calls (plist-get state :tool-calls)) (existing (assoc index calls))) (if existing (setcdr existing (my-llm--merge-tool-call (cdr existing) fragment)) (plist-put state :tool-calls (append calls (list (cons index (my-llm--merge-tool-call nil fragment)))))))) (defun my-llm--merge-tool-call (acc fragment) "Merge FRAGMENT into accumulated tool call ACC. The first fragment carries id and name; arguments arrive split across many." (let* ((fn (alist-get 'function fragment)) (id (or (alist-get 'id fragment) (alist-get 'id acc))) (name (or (alist-get 'name fn) (alist-get 'name (alist-get 'function acc)))) (args (concat (or (alist-get 'arguments (alist-get 'function acc)) "") (or (alist-get 'arguments fn) "")))) `((id . ,id) (type . "function") (function . ((name . ,name) (arguments . ,args)))))) (defun my-llm--local-sse-line (buf state line) "Handle one complete chat completions SSE LINE for BUF, accumulating into STATE." (when (string-prefix-p "data: " line) (let ((payload (substring line 6))) (unless (equal payload "[DONE]") (let* ((json (json-parse-string (decode-coding-string payload 'utf-8) :object-type 'alist)) (choice (aref (alist-get 'choices json) 0))) (when choice (when-let* ((reason (alist-get 'finish_reason choice))) (plist-put state :finish reason)) (when-let* ((delta (alist-get 'delta choice))) (when-let* ((text (alist-get 'content delta))) (my-llm--insert buf text nil)) (dolist (fragment (append (alist-get 'tool_calls delta) nil)) (my-llm--accumulate-tool-call state fragment))))))))) (defun my-llm--chatgpt-record-call (state item) "Record a finished function_call ITEM from the Responses stream in STATE." (let* ((calls (plist-get state :tool-calls)) (call `((id . ,(alist-get 'call_id item)) (type . "function") (function . ((name . ,(alist-get 'name item)) (arguments . ,(alist-get 'arguments item))))))) (plist-put state :tool-calls (append calls (list (cons (length calls) call)))))) (defun my-llm--chatgpt-fail (state message) "Append MESSAGE to the error text collected in STATE." (plist-put state :error-text (concat (plist-get state :error-text) message "\n"))) (defun my-llm--chatgpt-message (value) "The message carried by error VALUE, which is an alist, a string or nil." (cond ((null value) nil) ((stringp value) value) ((and (listp value) (alist-get 'message value))) (t (format "%S" value)))) (defun my-llm--chatgpt-event (buf state payload) "Handle one Responses API event PAYLOAD for BUF, accumulating into STATE." (let* ((event (json-parse-string (decode-coding-string payload 'utf-8) :object-type 'alist)) (type (alist-get 'type event)) (item (alist-get 'item event))) (pcase type ("response.output_text.delta" (my-llm--insert buf (alist-get 'delta event) nil)) ("response.refusal.delta" (my-llm--insert buf (alist-get 'delta event) 'my-llm-error-face)) ("response.output_item.done" (when (equal (alist-get 'type item) "function_call") (my-llm--chatgpt-record-call state item))) ("response.failed" (my-llm--chatgpt-fail state (or (my-llm--chatgpt-message (alist-get 'error (alist-get 'response event))) "response failed"))) ("error" (my-llm--chatgpt-fail state (or (my-llm--chatgpt-message (alist-get 'error event)) (my-llm--chatgpt-message event) "error"))) ((or "response.completed" "response.incomplete") (plist-put state :finish type) (when (equal (alist-get 'status (alist-get 'response event)) "failed") (my-llm--chatgpt-fail state (or (my-llm--chatgpt-message (alist-get 'error (alist-get 'response event))) "response failed"))))))) (defun my-llm--chatgpt-sse-line (buf state line) "Handle one complete Responses API SSE LINE for BUF, accumulating into STATE." (when (string-prefix-p "data: " line) (let ((payload (substring line 6))) (unless (equal payload "[DONE]") (my-llm--chatgpt-event buf state payload))))) (defun my-llm--sse-line (buf state line) "Handle one complete SSE LINE for BUF, in whichever dialect STATE speaks." (if (eq (plist-get state :provider) 'chatgpt) (my-llm--chatgpt-sse-line buf state line) (my-llm--local-sse-line buf state line))) (defun my-llm--flush-sse (buf state) "Emit all complete SSE lines buffered in STATE. Lines that are not SSE data frames come from an error body; keep them, but ignore the event and comment lines of a Responses stream." (let ((parts (split-string (plist-get state :sse) "\n"))) (plist-put state :sse (car (last parts))) (dolist (line (butlast parts)) (cond ((string-prefix-p "data: " line) (my-llm--sse-line buf state line)) ((and (eq (plist-get state :provider) 'chatgpt) (or (string-prefix-p "event: " line) (string-prefix-p ":" line))) nil) ((not (string-empty-p (string-trim line))) (plist-put state :error-text (concat (plist-get state :error-text) line "\n"))))))) (defun my-llm--drain (buf state) "Consume as much of BUF's raw stream as forms complete units." (catch 'waiting (when (eq (plist-get state :phase) 'headers) (let ((end (string-search "\r\n\r\n" (plist-get state :raw)))) (unless end (throw 'waiting nil)) (when (string-match "^HTTP/[0-9.]+ \\([0-9]+\\)" (plist-get state :head)) (plist-put state :status (string-to-number (match-string 1 (plist-get state :head))))) (plist-put state :raw (substring (plist-get state :raw) (+ end 4))) (plist-put state :phase (if (string-match-p "Transfer-Encoding: chunked" (plist-get state :head)) 'chunked 'plain)))) (while t (let ((raw (plist-get state :raw)) (remaining (plist-get state :remaining))) (cond ((eq (plist-get state :phase) 'plain) (plist-put state :raw "") (plist-put state :sse (concat (plist-get state :sse) raw)) (my-llm--flush-sse buf state) (throw 'waiting nil)) ((> remaining 0) (when (< (length raw) (+ remaining 2)) (throw 'waiting nil)) (plist-put state :sse (concat (plist-get state :sse) (substring raw 0 remaining))) (plist-put state :raw (substring raw (+ remaining 2))) (plist-put state :remaining 0) (my-llm--flush-sse buf state)) (t (let ((nl (string-search "\r\n" raw))) (unless nl (throw 'waiting nil)) (let ((size (string-to-number (substring raw 0 nl) 16))) (plist-put state :raw (substring raw (+ nl 2))) (if (= size 0) (progn (my-llm--complete buf state) (throw 'waiting nil)) (plist-put state :remaining size)))))))))) (defun my-llm--current (buf state) "Non-nil when STATE is still BUF's in-flight request. Filters and sentinels run with an arbitrary current buffer, so the buffer-local state has to be read from BUF itself." (and (buffer-live-p buf) (eq state (buffer-local-value 'my-llm--state buf)))) (defun my-llm--complete (buf state) "Finish the request described by STATE, once, and only if still current." (unless (plist-get state :done) (plist-put state :done t) (when (my-llm--current buf state) (with-current-buffer buf ;; A response without chunked encoding can end on an unterminated line: ;; keep it as error text rather than dropping it. (when (and (eq (plist-get state :phase) 'plain) (not (string-empty-p (plist-get state :sse)))) (plist-put state :sse (concat (plist-get state :sse) "\n")) (my-llm--flush-sse buf state)) (my-llm--finish-round buf state))))) (defun my-llm--request (buf url headers payload) "POST PAYLOAD to URL for chat BUF, streaming the answer into it. HEADERS is an alist of additional HTTP headers; PAYLOAD is the request body." (let* ((parsed (url-generic-parse-url url)) (secure (equal (url-type parsed) "https")) (host (url-host parsed)) (port (or (url-port parsed) (if secure 443 80))) (state (list :phase 'headers :head "" :raw "" :remaining 0 :sse "" :tool-calls nil :finish nil :done nil :status nil :error-text "" :provider my-llm-provider)) (request (concat "POST " (url-filename parsed) " HTTP/1.1\r\n" "Host: " host "\r\n" "Content-Type: application/json\r\n" "Accept: text/event-stream\r\n" (mapconcat (lambda (header) (format "%s: %s\r\n" (car header) (cdr header))) headers "") (format "Content-Length: %d\r\n" (string-bytes payload)) "Connection: close\r\n\r\n" payload))) (setq my-llm--state state) (when (process-live-p my-llm--proc) (delete-process my-llm--proc)) ;; `make-network-process' hands `:tls' to the system only in some builds; ;; `open-network-stream' negotiates TLS through GnuTLS every time. (let ((proc (open-network-stream "my-llm" nil host port :type (if secure 'tls 'plain) :coding 'binary :nowait nil :noquery t))) (set-process-filter proc (lambda (_proc chunk) (when (my-llm--current buf state) (when (eq (plist-get state :phase) 'headers) (plist-put state :head (concat (plist-get state :head) chunk))) (plist-put state :raw (concat (plist-get state :raw) chunk)) (my-llm--drain buf state)))) (set-process-sentinel proc (lambda (_proc _event) (my-llm--complete buf state))) (setq my-llm--proc proc) (process-send-string proc request)))) ;;; Conversation (defun my-llm--insert (buf text face &rest properties) "Append TEXT with FACE and PROPERTIES to BUF. Keep point at the end when it was there." (when (buffer-live-p buf) (with-current-buffer buf (let ((inhibit-read-only t) (at-end (= (point) (point-max)))) (save-excursion (goto-char (point-max)) (insert (apply #'propertize text 'face face properties))) (when at-end (goto-char (point-max))))))) (defun my-llm--message-content (lines) "Conversation text from LINES, without leading or trailing whitespace." (string-trim (mapconcat #'identity (nreverse lines) "\n"))) (defun my-llm--buffer-messages () "The conversation held in the current buffer, as OpenAI chat messages. A line beginning with `my-llm-prompt-marker' starts a user message, a line beginning with `my-llm-reply-marker' starts an assistant message, and lines beginning with a prefix in `my-llm--ui-prefixes' are chrome that is shown to the user but not sent." (let* ((messages nil) (role nil) (lines nil) (flush (lambda () (let ((content (my-llm--message-content lines))) (unless (or (null role) (string-empty-p content)) (push `((role . ,role) (content . ,content)) messages))) (setq lines nil)))) (dolist (line (split-string (buffer-substring-no-properties (point-min) (point-max)) "\n")) (cond ((string-prefix-p my-llm-prompt-marker line) (funcall flush) (setq role "user") (push (substring line (length my-llm-prompt-marker)) lines)) ((string-prefix-p my-llm-reply-marker line) (funcall flush) (setq role "assistant") (push (substring line (length my-llm-reply-marker)) lines)) ((seq-some (lambda (prefix) (string-prefix-p prefix line)) my-llm--ui-prefixes) nil) ((null role) nil) (t (push line lines)))) (funcall flush) (nreverse messages))) (defun my-llm--prefixed-lines (prefix text) "TEXT with PREFIX at the start of each line." (mapconcat (lambda (line) (concat prefix line)) (split-string (string-trim text) "\n") "\n")) (defun my-llm--notice (buf text) "Show TEXT in BUF as UI-only notice lines." (my-llm--insert buf (format "\n\n%s\n" (my-llm--prefixed-lines "\u26a0 " text)) 'my-llm-error-face)) (defun my-llm--append-prompt-marker (buf) "Start a fresh user message at the end of BUF. Point follows into it when it was already at the end of the buffer." (with-current-buffer buf (let ((at-end (= (point) (point-max)))) (save-excursion (goto-char (point-max)) (cond ((bobp) nil) ((bolp) (insert "\n")) (t (insert "\n\n"))) (insert (propertize my-llm-prompt-marker 'face 'my-llm-prompt-face))) (when at-end (goto-char (point-max)))))) (defun my-llm--start-reply (buf) "Begin a new assistant message in BUF. Return the position after its marker, where the reply streams in." (with-current-buffer buf (setq my-llm--reply-pos (point-max)) (save-excursion (goto-char (point-max)) (unless (bolp) (insert "\n")) (insert "\n" (propertize my-llm-reply-marker 'face 'my-llm-reply-face)) (point)))) (defun my-llm--tool-calls-in-order (state) "Tool calls accumulated in STATE, ordered by stream index." (mapcar #'cdr (sort (copy-sequence (plist-get state :tool-calls)) (lambda (a b) (< (car a) (car b)))))) (defun my-llm--summarize (result) "One-line summary of tool RESULT for display." (let* ((lines (split-string (string-trim result) "\n")) (extra (1- (length lines)))) (if (> extra 0) (format "%s ... (%d more lines)" (car lines) extra) (car lines)))) (defun my-llm--execute-tools (buf calls) "Run CALLS in BUF, returning the tool result messages. Displayed tool-log lines use reserved prefixes and are removed after the final answer." (mapcar (lambda (call) (let* ((id (alist-get 'id call)) (name (alist-get 'name (alist-get 'function call))) (raw (alist-get 'arguments (alist-get 'function call))) (handler (cdr (assoc name my-llm-tool-handlers)))) (my-llm--insert buf (format "\n\n%s\n" (my-llm--prefixed-lines "\u2699 " (format "%s %s" name (or raw "")))) 'my-llm-tool-face 'my-llm-tool-log t) (let ((result (cond ((null handler) (format "ERROR: unknown tool %s" name)) (t (condition-case err ;; Display-oriented tools change another window's buffer, ;; but never select it. Keep BUF current regardless so ;; conversation updates always land in the chat buffer. (with-current-buffer buf (save-current-buffer (funcall handler (json-parse-string (if (string-empty-p (or raw "")) "{}" raw) :object-type 'alist)))) (error (format "ERROR: %s" (error-message-string err)))))))) (my-llm--insert buf (format "%s\n" (my-llm--prefixed-lines "\u2502 " (my-llm--summarize result))) 'my-llm-dim-face 'my-llm-tool-log t) `((role . "tool") (tool_call_id . ,id) (content . ,result))))) calls)) (defun my-llm--tool-log-line-p () "Non-nil when the line at point is tool-call chrome." (or (looking-at-p (regexp-quote "\u2699 ")) (looking-at-p (regexp-quote "\u2502 ")))) (defun my-llm--clear-tool-log (buf) "Remove tool-call log lines from BUF while preserving conversation spacing. Tool chrome is recognized by its reserved line prefixes rather than text properties. This also cleans logs inserted before this function was loaded or whose properties were removed by copying or editing." (with-current-buffer buf (let ((inhibit-read-only t) (at-end (= (point) (point-max)))) (save-restriction (widen) (save-excursion (goto-char (point-min)) (while (re-search-forward (concat "^" (regexp-opt '("\u2699 " "\u2502 "))) nil t) (goto-char (line-beginning-position)) ;; Include blank separator lines before this tool block. (let ((beg (point))) (while (and (> beg (point-min)) (progn (forward-line -1) (looking-at-p "[[:blank:]]*$"))) (setq beg (point))) (goto-char beg) ;; A block can contain several tool calls separated by blanks. (while (and (< (point) (point-max)) (or (looking-at-p "[[:blank:]]*$") (my-llm--tool-log-line-p))) (forward-line 1)) (let ((end (point))) (delete-region beg end) ;; Keep ordinary chat turns separated by one empty line. (when (and (> beg (point-min)) (< beg (point-max))) (insert "\n"))))))) (when at-end (goto-char (point-max)))))) (defun my-llm--last-assistant-text () "Text of the assistant message that just finished streaming." (string-trim (buffer-substring-no-properties (or my-llm--text-start (point-min)) (point-max)))) (defun my-llm--remember-assistant (text) "Add assistant TEXT to this buffer's conversation, unless it is empty." (unless (string-empty-p text) (setq my-llm--messages (append my-llm--messages (list `((role . "assistant") (content . ,text))))))) (defun my-llm--finish-round (buf state) "Handle the end of a streamed response in BUF: run tools, or stop." (let* ((calls (my-llm--tool-calls-in-order state)) (error-text (plist-get state :error-text)) (status (plist-get state :status)) (text (my-llm--last-assistant-text))) (cond ((and error-text (not (string-empty-p error-text))) (with-current-buffer buf (when (string-empty-p text) (my-llm--delete-empty-reply buf)) (my-llm--notice buf (format "request failed%s: %s" (if status (format " (HTTP %s)" status) "") (string-trim error-text))) (my-llm--finish buf "error"))) ((null calls) (with-current-buffer buf (my-llm--remember-assistant text) (my-llm--clear-tool-log buf) (my-llm--finish buf "done"))) (t (with-current-buffer buf (when (string-empty-p text) (my-llm--delete-empty-reply buf)) (setq my-llm--messages (append my-llm--messages (list `((role . "assistant") (content . ,(if (string-empty-p text) :null text)) (tool_calls . ,(apply #'vector calls)))))) (setq my-llm--messages (append my-llm--messages (my-llm--execute-tools buf calls)))) (my-llm--send buf))))) (defun my-llm--send (buf) "Send the current conversation to the model for BUF. Opens a new assistant message for the reply to stream into." (with-current-buffer buf (setq my-llm--text-start (my-llm--start-reply buf)) (setq my-llm--request-start (float-time)) (my-llm--start-spinner buf) (if (eq my-llm-provider 'chatgpt) (my-llm--send-chatgpt buf) (my-llm--send-local buf)))) (defun my-llm--payload (body) "BODY as a UTF-8 JSON request payload." (encode-coding-string (json-serialize body) 'utf-8)) (defun my-llm--local-body () "Request body for the OpenAI-compatible endpoint." `((model . ,my-llm-model) (stream . t) (messages . ,(apply #'vector (cons `((role . "system") (content . ,my-llm-system-prompt)) my-llm--messages))) (tools . ,my-llm-tools))) (defun my-llm--send-local (buf) "Send the conversation to the OpenAI-compatible endpoint for BUF." (my-llm--request buf my-llm-endpoint (when my-llm-api-key `(("Authorization" . ,(format "Bearer %s" my-llm-api-key)))) (my-llm--payload (my-llm--local-body)))) (defun my-llm--chatgpt-tools () "`my-llm-tools' in the flat schema the Responses API expects." (apply #'vector (mapcar (lambda (tool) (let ((function (alist-get 'function tool))) `((type . "function") (name . ,(alist-get 'name function)) (description . ,(alist-get 'description function)) (parameters . ,(alist-get 'parameters function)) (strict . :false)))) (append my-llm-tools nil)))) (defun my-llm--chatgpt-input () "The conversation as Responses API input items." (let ((items nil) (index 0)) (dolist (message my-llm--messages) (pcase (alist-get 'role message) ("user" (push `((role . "user") (content . ,(vector `((type . "input_text") (text . ,(alist-get 'content message)))))) items)) ("assistant" (let ((text (alist-get 'content message))) (unless (eq text :null) (push `((type . "message") (id . ,(format "msg_my_llm_%d" index)) (role . "assistant") (status . "completed") (content . ,(vector `((type . "output_text") (text . ,text) (annotations . []))))) items)) (dolist (call (append (alist-get 'tool_calls message) nil)) (let ((function (alist-get 'function call))) (push `((type . "function_call") (call_id . ,(alist-get 'id call)) (name . ,(alist-get 'name function)) (arguments . ,(alist-get 'arguments function))) items))))) ("tool" (push `((type . "function_call_output") (call_id . ,(alist-get 'tool_call_id message)) (output . ,(alist-get 'content message))) items))) (setq index (1+ index))) (apply #'vector (nreverse items)))) (defun my-llm--chatgpt-body () "Request body for the ChatGPT Codex Responses backend." `((model . ,my-llm-chatgpt-model) (store . :false) (stream . t) ,@(when my-llm-chatgpt-reasoning-effort `((reasoning . ((effort . ,my-llm-chatgpt-reasoning-effort))))) (instructions . ,my-llm-system-prompt) (input . ,(my-llm--chatgpt-input)) (tool_choice . "auto") (parallel_tool_calls . t) (tools . ,(my-llm--chatgpt-tools)))) (defun my-llm--send-chatgpt (buf) "Send the conversation to ChatGPT for BUF, with pi's credentials." (let* ((credentials (my-llm--chatgpt-credentials)) (token (car credentials)) (account (cdr credentials))) (my-llm--request buf my-llm-chatgpt-endpoint `(("Authorization" . ,(format "Bearer %s" token)) ("chatgpt-account-id" . ,account) ("originator" . "pi") ("OpenAI-Beta" . "responses=experimental") ("User-Agent" . ,(format "my-llm.el (Emacs %s)" emacs-version))) (my-llm--payload (my-llm--chatgpt-body))))) ;;; User interface (defun my-llm--spinner-frame () "Current frame of the waiting indicator." (aref my-llm--spinner-frames (mod my-llm--spinner-index (length my-llm--spinner-frames)))) (defun my-llm--stop-spinner () "Stop animating the waiting indicator of the current buffer." (when (timerp my-llm--spinner-timer) (cancel-timer my-llm--spinner-timer)) (setq my-llm--spinner-timer nil)) (defun my-llm--start-spinner (buf) "Animate the waiting indicator of BUF while its request is in flight." (with-current-buffer buf (my-llm--stop-spinner) (setq my-llm--spinner-index 0) (setq my-llm--spinner-timer (run-at-time 0 0.2 (lambda () (when (buffer-live-p buf) (with-current-buffer buf (setq my-llm--spinner-index (1+ my-llm--spinner-index)) (force-mode-line-update t)))))))) (defun my-llm--model-label () "Backend and model the next request will use. `local' is the user's own server (vLLM), as opposed to the ChatGPT API." (if (eq my-llm-provider 'chatgpt) (format "chatgpt %s" my-llm-chatgpt-model) (format "vllm %s" my-llm-model))) (defun my-llm--age-string (seconds) "Human-readable age of SECONDS." (cond ((< seconds 60) (format "%ds" (round seconds))) ((< seconds 3600) (format "%dm" (round (/ seconds 60)))) (t (format "%dh" (round (/ seconds 3600)))))) (defun my-llm--header-line () "Header line of a my-llm buffer: backend, request state and key bindings." (let ((state (cond (my-llm--busy (propertize (format "%s waiting for the model (%ds)" (my-llm--spinner-frame) (round (- (float-time) (or my-llm--request-start (float-time))))) 'face 'my-llm-progress-face)) (my-llm--last-stopped (propertize (format "%s %s ago" (or my-llm--last-note "done") (my-llm--age-string (float-time (time-since my-llm--last-stopped)))) 'face (if (equal my-llm--last-note "done") 'my-llm-dim-face 'my-llm-error-face))) (t (propertize "ready" 'face 'my-llm-dim-face))))) (replace-regexp-in-string "%" "%%" (format " %s \u00b7 %s \u00b7 %s \u00b7 C-c C-c send C-c C-k cancel" (propertize "my-llm" 'face 'bold) (my-llm--model-label) state) t t))) (defun my-llm--mode-line-process () "Mode line indicator: a spinner while waiting for the model, else nothing." (if my-llm--busy (format " %s" (my-llm--spinner-frame)) "")) (defun my-llm--finish (buf note) "Mark BUF as done waiting for the model, with NOTE describing the outcome. Appends the marker for the next prompt." (with-current-buffer buf (setq my-llm--busy nil) (setq my-llm--last-note note) (setq my-llm--last-stopped (current-time)) (my-llm--stop-spinner) (my-llm--append-prompt-marker buf) (force-mode-line-update t))) (defun my-llm--cleanup () "Stop the spinner and any in-flight request in the current buffer." (my-llm--stop-spinner) (when (process-live-p my-llm--proc) (delete-process my-llm--proc))) (defun my-llm--delete-empty-reply (buf) "Remove the assistant marker in BUF when nothing was written after it." (with-current-buffer buf (when (and my-llm--reply-pos my-llm--text-start (<= my-llm--reply-pos my-llm--text-start (point-max)) (string-empty-p (string-trim (buffer-substring-no-properties my-llm--text-start (point-max))))) (let ((inhibit-read-only t)) (delete-region my-llm--reply-pos (point-max)))))) (defun my-llm--start-request (buf) "Send the pending user message of BUF to the model." (with-current-buffer buf (when my-llm--busy (user-error "Already waiting for the model (C-c C-k cancels)")) (let ((messages (my-llm--buffer-messages))) (unless (equal "user" (alist-get 'role (car (last messages)))) (user-error "Nothing to send: type a prompt after \"%s\"" (string-trim my-llm-prompt-marker))) (setq my-llm--messages messages) (setq my-llm--busy t) (condition-case err (my-llm--send buf) (error (my-llm--delete-empty-reply buf) (my-llm--notice buf (format "request failed: %s" (error-message-string err))) (my-llm--finish buf "error")))))) (defvar my-llm-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "C-c C-c") #'my-llm-send) (define-key map (kbd "C-c C-k") #'my-llm-cancel) map)) (define-derived-mode my-llm-mode fundamental-mode "my-llm" "Major mode for the my-llm chat buffer. The buffer is the conversation that gets sent to the model: a line starting with \"\u276f \" begins a user message and a line starting with \"\u23fa \" begins an assistant message. Edit any of it freely, and type new prompts after the last \"\u276f \"; \\[my-llm-send] sends the conversation and the reply streams in below." (setq-local buffer-read-only nil) (setq-local header-line-format '(:eval (my-llm--header-line))) (setq-local mode-line-process '(:eval (my-llm--mode-line-process))) (add-hook 'kill-buffer-hook #'my-llm--cleanup nil t)) ;;;###autoload (defun my-llm-send () "Send the conversation in the my-llm buffer to the model. The buffer itself is the conversation: user messages begin with `my-llm-prompt-marker' and assistant messages with `my-llm-reply-marker'." (interactive) (unless (derived-mode-p 'my-llm-mode) (my-llm)) (my-llm--start-request (current-buffer))) ;;;###autoload (defun my-llm-cancel () "Cancel the request in flight in the my-llm buffer." (interactive) (unless (derived-mode-p 'my-llm-mode) (user-error "Not in a my-llm buffer")) (unless my-llm--busy (user-error "No request in flight")) (when my-llm--state (plist-put my-llm--state :done t)) (when (process-live-p my-llm--proc) (delete-process my-llm--proc)) (setq my-llm--proc nil) (my-llm--delete-empty-reply (current-buffer)) (my-llm--notice (current-buffer) "cancelled") (my-llm--finish (current-buffer) "cancelled")) ;;;###autoload (defun my-llm () "Open (or return to) the my-llm chat buffer for the current project. The buffer is editable and holds the whole conversation; type your prompt after the last \"\u276f \" and press \\[my-llm-send] to send it." (interactive) (let* ((origin (current-buffer)) (root (or (when-let* ((project (project-current nil))) (expand-file-name (project-root project))) (expand-file-name default-directory))) (selection (when (use-region-p) (buffer-substring-no-properties (region-beginning) (region-end)))) (buf (get-buffer-create (format "*my-llm: %s*" (file-name-nondirectory (directory-file-name root)))))) (with-current-buffer buf (unless (derived-mode-p 'my-llm-mode) (my-llm-mode) (my-llm--append-prompt-marker buf)) (setq my-llm--origin-root root) ;; Sending from a chat buffer itself keeps the previous origin. (unless (eq origin buf) (setq my-llm--origin-buffer origin) (setq my-llm--origin-selection selection))) (pop-to-buffer buf) (goto-char (point-max)))) (provide 'my-llm) ;;; my-llm.el ends here