gptel-context.el (23403B)
1 ;;; gptel-context.el --- Context aggregator for GPTel -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2023 Karthik Chikmagalur 4 5 ;; Author: daedsidog <contact@daedsidog.com> 6 ;; Keywords: convenience, buffers 7 8 ;; SPDX-License-Identifier: GPL-3.0-or-later 9 10 ;; This program is free software; you can redistribute it and/or modify 11 ;; it under the terms of the GNU General Public License as published by 12 ;; the Free Software Foundation, either version 3 of the License, or 13 ;; (at your option) any later version. 14 15 ;; This program is distributed in the hope that it will be useful, 16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 ;; GNU General Public License for more details. 19 20 ;; You should have received a copy of the GNU General Public License 21 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 22 23 ;;; Commentary: 24 25 ;; The context allows you to conveniently create contexts which can be fed 26 ;; to GPTel. 27 28 ;;; Code: 29 30 ;;; -*- lexical-binding: t -*- 31 (require 'gptel) 32 (require 'cl-lib) 33 34 (declare-function gptel-menu "gptel-transient") 35 (declare-function dired-get-marked-files "dired") 36 (declare-function image-file-name-regexp "image-file") 37 (declare-function create-image "image") 38 39 (defface gptel-context-highlight-face 40 '((((background dark) (min-colors 88)) :background "gray4" :extend t) 41 (((background light) (min-colors 88)) :background "alice blue" :extend t) 42 (t :inherit mode-line)) 43 "Face used to highlight gptel contexts in buffers." 44 :group 'gptel) 45 46 (defface gptel-context-deletion-face 47 '((((class color) (min-colors 257) (background light)) 48 :background "#ffeeee" :extend t) 49 (((class color) (min-colors 88) (background light)) 50 :background "#ffdddd" :extend t) 51 (((class color) (min-colors 88) (background dark)) 52 :background "#553333" :extend t) 53 (((class color)) :foreground "red" :extend t)) 54 "Face used to highlight gptel contexts to be deleted. 55 56 This is used in gptel context buffers." 57 :group 'gptel) 58 59 (defcustom gptel-context-wrap-function #'gptel-context--wrap-default 60 "Function to format the context string sent with the gptel request. 61 62 This function receives two argument, the message to wrap with the 63 context, and an alist of contexts organized by buffer. It should 64 return a string containing the message and the context, formatted as 65 necessary. 66 67 The message is either the system message or the last user prompt, 68 as configured by `gptel-use-context'. 69 70 The alist of contexts is structured as follows: 71 72 ((buffer1 . (overlay1 overlay2) 73 (\"path/to/file\") 74 (buffer2 . (overlay3 overlay4 overlay5)) 75 (\"path/to/image/file\" :mime \"image/jpeg\"))) 76 77 Each gptel \"context\" is either a file path or an overlay in a 78 buffer. Each overlay covers a buffer region containing the 79 context chunk. This is accessible as, for example: 80 81 (with-current-buffer buffer1 82 (buffer-substring (overlay-start overlay1) 83 (overlay-end overlay1)))" 84 :group 'gptel 85 :type 'function) 86 87 (defun gptel-context-add (&optional arg) 88 "Add context to gptel in a DWIM fashion. 89 90 - If a region is selected, add the selected region to the 91 context. If there is already a gptel context at point, remove it 92 instead. 93 94 - If in Dired, add marked files or file at point to the context. 95 With negative prefix ARG, remove them from the context instead. 96 97 - Otherwise add the current buffer to the context. With positive 98 prefix ARG, prompt for a buffer name and add it to the context. 99 100 - With negative prefix ARG, remove all gptel contexts from the 101 current buffer." 102 (interactive "P") 103 (cond 104 ;; A region is selected. 105 ((use-region-p) 106 (gptel-context--add-region (current-buffer) 107 (region-beginning) 108 (region-end)) 109 (deactivate-mark) 110 (message "Current region added as context.")) 111 ;; If in dired 112 ((derived-mode-p 'dired-mode) 113 (mapc (if (and arg (< (prefix-numeric-value arg) 0)) 114 #'gptel-context-remove 115 #'gptel-context-add-file) 116 (dired-get-marked-files))) 117 ;; If in an image buffer 118 ((and (derived-mode-p 'image-mode) 119 (gptel--model-capable-p 'media;) 120 (buffer-file-name)) 121 (funcall (if (and arg (< (prefix-numeric-value arg) 0)) 122 #'gptel-context-remove 123 #'gptel-context-add-file) 124 (buffer-file-name)))) 125 ;; No region is selected, and ARG is positive. 126 ((and arg (> (prefix-numeric-value arg) 0)) 127 (let* ((buffer-name (read-buffer "Choose buffer to add as context: " nil t)) 128 (start (with-current-buffer buffer-name (point-min))) 129 (end (with-current-buffer buffer-name (point-max)))) 130 (gptel-context--add-region 131 (get-buffer buffer-name) start end t) 132 (message "Buffer '%s' added as context." buffer-name))) 133 ;; No region is selected, and ARG is negative. 134 ((and arg (< (prefix-numeric-value arg) 0)) 135 (when (y-or-n-p "Remove all contexts from this buffer? ") 136 (let ((removed-contexts 0)) 137 (cl-loop for cov in 138 (gptel-context--in-region (current-buffer) (point-min) (point-max)) 139 do (progn 140 (cl-incf removed-contexts) 141 (gptel-context-remove cov))) 142 (message (format "%d context%s removed from current buffer." 143 removed-contexts 144 (if (= removed-contexts 1) "" "s")))))) 145 (t ; Default behavior 146 (if (gptel-context--at-point) 147 (progn 148 (gptel-context-remove (car (gptel-context--in-region (current-buffer) 149 (max (point-min) (1- (point))) 150 (point)))) 151 (message "Context under point has been removed.")) 152 (gptel-context--add-region (current-buffer) (point-min) (point-max) t) 153 (message "Current buffer added as context."))))) 154 155 ;;;###autoload (autoload 'gptel-add "gptel-context" "Add/remove regions or buffers from gptel's context." t) 156 (defalias 'gptel-add #'gptel-context-add) 157 158 (defun gptel--file-binary-p (path) 159 "Check if file at PATH is readable and binary." 160 (condition-case nil 161 (with-temp-buffer 162 (insert-file-contents path nil 1 512 'replace) 163 (eq buffer-file-coding-system 'no-conversion)) 164 (file-missing (message "File \"%s\" is not readable." path)))) 165 166 (defun gptel-context-add-file (path) 167 "Add the file at PATH to the gptel context. 168 169 PATH should be readable as text." 170 (interactive "fChoose file to add to context: ") 171 (if (gptel--file-binary-p path) ;Attach if supported 172 (if-let* (((gptel--model-capable-p 'media)) 173 (mime (mailcap-file-name-to-mime-type path)) 174 ((gptel--model-mime-capable-p mime))) 175 (prog1 path 176 (cl-pushnew (list path :mime mime) 177 gptel-context--alist :test #'equal) 178 (message "File \"%s\" added to context." path)) 179 (message "Ignoring unsupported binary file \"%s\"." path)) 180 ;; Add text file 181 (cl-pushnew (list path) gptel-context--alist :test #'equal) 182 (message "File \"%s\" added to context." path) 183 path)) 184 185 ;;;###autoload (autoload 'gptel-add-file "gptel-context" "Add files to gptel's context." t) 186 (defalias 'gptel-add-file #'gptel-context-add-file) 187 188 (defun gptel-context-remove (&optional context) 189 "Remove the CONTEXT overlay from the contexts list. 190 If CONTEXT is nil, removes the context at point. 191 If selection is active, removes all contexts within selection." 192 (cond 193 ((overlayp context) 194 (delete-overlay context) 195 ;; FIXME: Quadratic cost when clearing a bunch of contexts at once 196 (unless 197 (cl-loop 198 for ov in (alist-get (current-buffer) gptel-context--alist) 199 thereis (overlay-start ov)) 200 (setf (alist-get (current-buffer) gptel-context--alist nil 'remove) nil))) 201 ((stringp context) ;file 202 (setf (alist-get context gptel-context--alist nil 'remove #'equal) 203 nil)) 204 ((region-active-p) 205 (when-let ((contexts (gptel-context--in-region (current-buffer) 206 (region-beginning) 207 (region-end)))) 208 (cl-loop for ctx in contexts do (delete-overlay ctx)))) 209 (t 210 (when-let ((ctx (gptel-context--at-point))) 211 (delete-overlay ctx))))) 212 213 (defun gptel-context--make-overlay (start end &optional advance) 214 "Highlight the region from START to END. 215 216 ADVANCE controls the overlay boundary behavior." 217 (let ((overlay (make-overlay start end nil (not advance) advance))) 218 (overlay-put overlay 'evaporate t) 219 (overlay-put overlay 'face 'gptel-context-highlight-face) 220 (overlay-put overlay 'gptel-context t) 221 (push overlay (alist-get (current-buffer) 222 gptel-context--alist)) 223 overlay)) 224 225 ;;;###autoload 226 (defun gptel-context--wrap (message) 227 "Wrap MESSAGE with context string." 228 (funcall gptel-context-wrap-function 229 message (gptel-context--collect))) 230 231 (defun gptel-context--wrap-default (message contexts) 232 "Add CONTEXTS to MESSAGE. 233 234 MESSAGE is usually either the system message or the user prompt. 235 The accumulated context from CONTEXTS is appended or prepended to 236 it, respectively." 237 ;; Append context before/after system message. 238 (let ((context-string (gptel-context--string contexts))) 239 (if (> (length context-string) 0) 240 (pcase-exhaustive gptel-use-context 241 ('system (concat message "\n\n" context-string)) 242 ('user (concat context-string "\n\n" message)) 243 ('nil message)) 244 message))) 245 246 (defun gptel-context--collect-media (&optional contexts) 247 "Collect media CONTEXTS. 248 249 CONTEXTS, which are typically paths to binary files, are 250 base64-encoded and prepended to the first user prompt." 251 (cl-loop for context in (or contexts gptel-context--alist) 252 for (path . props) = context 253 when (and (stringp path) (plist-get props :mime)) 254 collect (cons :media context))) 255 256 (cl-defun gptel-context--add-region (buffer region-beginning region-end &optional advance) 257 "Add region delimited by REGION-BEGINNING, REGION-END in BUFFER as context. 258 259 If ADVANCE is non-nil, the context overlay envelopes changes at 260 the beginning and end." 261 ;; Remove existing contexts in the same region, if any. 262 (mapc #'gptel-context-remove 263 (gptel-context--in-region buffer region-beginning region-end)) 264 (prog1 (with-current-buffer buffer 265 (gptel-context--make-overlay region-beginning region-end advance)) 266 (message "Region added to context buffer."))) 267 268 (defun gptel-context--in-region (buffer start end) 269 "Return the list of context overlays in the given region, if any, in BUFFER. 270 START and END signify the region delimiters." 271 (with-current-buffer buffer 272 (cl-remove-if-not (lambda (ov) (overlay-get ov 'gptel-context)) 273 (overlays-in start end)))) 274 275 (defun gptel-context--at-point () 276 "Return the context overlay at point, if any." 277 (cl-find-if (lambda (ov) (overlay-get ov 'gptel-context)) 278 (overlays-at (point)))) 279 280 ;;;###autoload 281 (defun gptel-context--collect () 282 "Get the list of all active context overlays." 283 ;; Get only the non-degenerate overlays, collect them, and update the overlays variable. 284 (setq gptel-context--alist 285 (cl-loop for (buf . ovs) in gptel-context--alist 286 if (buffer-live-p buf) 287 if (cl-loop for ov in ovs when (overlay-start ov) collect ov) 288 collect (cons buf it) into elements 289 end 290 else if (and (stringp buf) (file-exists-p buf)) 291 if (plist-get ovs :mime) 292 collect (cons buf ovs) into elements 293 else collect (list buf) into elements 294 finally return elements))) 295 296 (defun gptel-context--insert-buffer-string (buffer contexts) 297 "Insert at point a context string from all CONTEXTS in BUFFER." 298 (let ((is-top-snippet t) 299 (previous-line 1)) 300 (insert (format "In buffer `%s`:" (buffer-name buffer)) 301 "\n\n```" (gptel--strip-mode-suffix (buffer-local-value 302 'major-mode buffer)) 303 "\n") 304 (dolist (context contexts) 305 (let* ((start (overlay-start context)) 306 (end (overlay-end context)) 307 content) 308 (let (lineno column) 309 (with-current-buffer buffer 310 (without-restriction 311 (setq lineno (line-number-at-pos start t) 312 column (save-excursion (goto-char start) 313 (current-column)) 314 content (buffer-substring-no-properties start end)))) 315 ;; We do not need to insert a line number indicator if we have two regions 316 ;; on the same line, because the previous region should have already put the 317 ;; indicator. 318 (unless (= previous-line lineno) 319 (unless (= lineno 1) 320 (unless is-top-snippet 321 (insert "\n")) 322 (insert (format "... (Line %d)\n" lineno)))) 323 (setq previous-line lineno) 324 (unless (zerop column) (insert " ...")) 325 (if is-top-snippet 326 (setq is-top-snippet nil) 327 (unless (= previous-line lineno) (insert "\n")))) 328 (insert content))) 329 (unless (>= (overlay-end (car (last contexts))) (point-max)) 330 (insert "\n...")) 331 (insert "\n```"))) 332 333 (defun gptel-context--insert-file-string (path) 334 "Insert at point the contents of the file at PATH as context." 335 (insert (format "In file `%s`:" (file-name-nondirectory path)) 336 "\n\n```\n") 337 (insert-file-contents path) 338 (goto-char (point-max)) 339 (insert "\n```\n")) 340 341 (defun gptel-context--string (context-alist) 342 "Format the aggregated gptel context as annotated markdown fragments. 343 344 Returns a string. CONTEXT-ALIST is a structure containing 345 context overlays, see `gptel-context--alist'." 346 (with-temp-buffer 347 (cl-loop for (buf . ovs) in context-alist 348 if (bufferp buf) 349 do (gptel-context--insert-buffer-string buf ovs) 350 else if (not (plist-get ovs :mime)) 351 do (gptel-context--insert-file-string buf) end 352 do (insert "\n\n") 353 finally do 354 (skip-chars-backward "\n\t\r ") 355 (delete-region (point) (point-max)) 356 (unless (bobp) 357 (goto-char (point-min)) 358 (insert "Request context:\n\n")) 359 finally return 360 (and (> (buffer-size) 0) 361 (buffer-string))))) 362 363 ;;; Major mode for context inspection buffers 364 (defvar-keymap gptel-context-buffer-mode-map 365 "C-c C-c" #'gptel-context-confirm 366 "C-c C-k" #'gptel-context-quit 367 "RET" #'gptel-context-visit 368 "n" #'gptel-context-next 369 "p" #'gptel-context-previous 370 "d" #'gptel-context-flag-deletion) 371 372 (define-derived-mode gptel-context-buffer-mode special-mode "gptel-context" 373 "Major-mode for inspecting context used by gptel." 374 :group 'gptel 375 (add-hook 'post-command-hook #'gptel-context--post-command 376 nil t) 377 (setq-local revert-buffer-function #'gptel-context--buffer-setup)) 378 379 (defun gptel-context--buffer-setup (&optional _ignore-auto _noconfirm) 380 "Set up the gptel context buffer." 381 (with-current-buffer (get-buffer-create "*gptel-context*") 382 (gptel-context-buffer-mode) 383 (let ((inhibit-read-only t)) 384 (erase-buffer) 385 (setq header-line-format 386 (concat 387 (propertize "d" 'face 'help-key-binding) ": Mark/unmark deletion, " 388 (propertize "n" 'face 'help-key-binding) "/" 389 (propertize "p" 'face 'help-key-binding) ": jump to next/previous, " 390 (propertize "C-c C-c" 'face 'help-key-binding) ": apply, " 391 (propertize "C-c C-k" 'face 'help-key-binding) ": cancel, " 392 (propertize "q" 'face 'help-key-binding) ": quit")) 393 (save-excursion 394 (let ((contexts gptel-context--alist)) 395 (if (length> contexts 0) 396 (let (beg ov l1 l2) 397 (pcase-dolist (`(,buf . ,ovs) contexts) 398 (if (bufferp buf) 399 ;; It's a buffer with some overlay(s) 400 (dolist (source-ov ovs) 401 (with-current-buffer buf 402 (setq l1 (line-number-at-pos (overlay-start source-ov)) 403 l2 (line-number-at-pos (overlay-end source-ov)))) 404 (insert (propertize (format "In buffer %s (lines %d-%d):\n\n" 405 (buffer-name buf) l1 l2) 406 'face 'bold)) 407 (setq beg (point)) 408 (insert-buffer-substring 409 buf (overlay-start source-ov) (overlay-end source-ov)) 410 (insert "\n") 411 (setq ov (make-overlay beg (point))) 412 (overlay-put ov 'gptel-context source-ov) 413 (overlay-put ov 'gptel-overlay t) 414 (overlay-put ov 'evaporate t) 415 (insert "\n" (make-separator-line) "\n")) 416 ;; BUF is a file path, not a buffer 417 (insert (propertize (format "In file %s:\n\n" (file-name-nondirectory buf)) 418 'face 'bold)) 419 (setq beg (point)) 420 (if-let ((mime (plist-get ovs :mime))) 421 ;; BUF is a binary file 422 (if-let (((string-match-p (image-file-name-regexp) buf)) 423 (img (create-image buf))) 424 (insert-image img "*") ; Can be displayed 425 (insert 426 buf " " (propertize "(No preview for binary file)" 427 'face '(:inherit shadow :slant italic)))) 428 (insert-file-contents buf)) 429 (goto-char (point-max)) 430 (insert "\n") 431 (setq ov (make-overlay beg (point))) 432 (overlay-put ov 'gptel-context buf) 433 (overlay-put ov 'gptel-overlay t) 434 (overlay-put ov 'evaporate t) 435 (insert "\n" (make-separator-line) "\n"))) 436 (goto-char (point-min))) 437 (insert "There are no active gptel contexts."))))) 438 (display-buffer (current-buffer) 439 `((display-buffer-reuse-window 440 display-buffer-reuse-mode-window 441 display-buffer-below-selected) 442 (body-function . ,#'select-window) 443 (window-height . ,#'fit-window-to-buffer))))) 444 445 (defvar gptel-context--buffer-reverse nil 446 "Last direction of cursor movement in gptel context buffer. 447 448 If non-nil, indicates backward movement.") 449 450 (defalias 'gptel-context--post-command 451 (let ((highlight-overlay)) 452 (lambda () 453 ;; Only update if point moved outside the current region. 454 (unless (memq highlight-overlay (overlays-at (point))) 455 (let ((context-overlay 456 (cl-loop for ov in (overlays-at (point)) 457 thereis (and (overlay-get ov 'gptel-overlay) ov)))) 458 (when highlight-overlay 459 (overlay-put highlight-overlay 'face nil)) 460 (when context-overlay 461 (overlay-put context-overlay 'face 'highlight)) 462 (setq highlight-overlay context-overlay)))))) 463 464 (defun gptel-context-visit () 465 "Display the location of this gptel context chunk in its original buffer." 466 (interactive) 467 (let ((ov-here (car (overlays-at (point))))) 468 (if-let* ((orig-ov (overlay-get ov-here 'gptel-context)) 469 (buf (overlay-buffer orig-ov)) 470 (offset (- (point) (overlay-start ov-here)))) 471 (with-selected-window (display-buffer buf) 472 (goto-char (overlay-start orig-ov)) 473 (forward-char offset) 474 (recenter)) 475 (message "No source location for this gptel context chunk.")))) 476 477 (defun gptel-context-next () 478 "Move to next gptel context chunk." 479 (interactive) 480 (let ((ov-here (car (overlays-at (point)))) 481 (next-start (next-overlay-change (point)))) 482 (when (and (/= (point-max) next-start) ov-here) 483 ;; We were inside the overlay, so we want the next overlay change, which 484 ;; would be the start of the next overlay. 485 (setq next-start (next-overlay-change next-start))) 486 (when (/= next-start (point-max)) 487 (setq gptel-context--buffer-reverse nil) 488 (goto-char next-start) 489 (recenter (floor (window-height) 4))))) 490 491 (defun gptel-context-previous () 492 "Move to previous gptel context chunk." 493 (interactive) 494 (let ((ov-here (car (overlays-at (point))))) 495 (when ov-here (goto-char (overlay-start ov-here))) 496 (let ((previous-context-pos (previous-overlay-change 497 (previous-overlay-change (point))))) 498 ;; Prevent point from jumping to the start of the buffer. 499 (unless (= previous-context-pos (point-min)) 500 (goto-char previous-context-pos) 501 (recenter (floor (window-height) 4)) 502 (setq gptel-context--buffer-reverse t))))) 503 504 (defun gptel-context-flag-deletion () 505 "Mark gptel context chunk at point for removal." 506 (interactive) 507 (let* ((overlays (if (use-region-p) 508 (overlays-in (region-beginning) (region-end)) 509 (overlays-at (point)))) 510 (deletion-ov) 511 (marked-ovs (cl-remove-if-not (lambda (ov) (overlay-get ov 'gptel-context-deletion-mark)) 512 overlays))) 513 (if marked-ovs 514 (mapc #'delete-overlay marked-ovs) 515 (save-excursion 516 (dolist (ov overlays) 517 (when (overlay-get ov 'gptel-context) 518 (goto-char (overlay-start ov)) 519 (setq deletion-ov (make-overlay (overlay-start ov) (overlay-end ov))) 520 (overlay-put deletion-ov 'gptel-context (overlay-get ov 'gptel-context)) 521 (overlay-put deletion-ov 'priority -80) 522 (overlay-put deletion-ov 'face 'gptel-context-deletion-face) 523 (overlay-put deletion-ov 'gptel-context-deletion-mark t))))) 524 (if (use-region-p) 525 (deactivate-mark) 526 (if gptel-context--buffer-reverse 527 (gptel-context-previous) 528 (gptel-context-next))))) 529 530 (defun gptel-context-quit () 531 "Cancel pending operations and return to gptel's menu." 532 (interactive) 533 (quit-window) 534 (call-interactively #'gptel-menu)) 535 536 (defun gptel-context-confirm () 537 "Confirm pending operations and return to gptel's menu." 538 (interactive) 539 ;; Delete all the context overlays that have been marked for deletion. 540 (mapc #'gptel-context-remove 541 (delq nil (mapcar (lambda (ov) 542 (and 543 (overlay-get ov 'gptel-context-deletion-mark) 544 (overlay-get ov 'gptel-context))) 545 (overlays-in (point-min) (point-max))))) 546 (gptel-context-quit)) 547 548 (provide 'gptel-context) 549 ;;; gptel-context.el ends here.