gptel-context.el (24094B)
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-remove-all () 214 "Remove all gptel context." 215 (cl-loop 216 for (source . ovs) in gptel-context--alist 217 if (bufferp source) do ;Buffers and buffer regions 218 (mapc #'gptel-context-remove ovs) 219 else do (gptel-context-remove source) ;files or other types 220 finally do (setq gptel-context--alist nil))) 221 222 (defun gptel-context--make-overlay (start end &optional advance) 223 "Highlight the region from START to END. 224 225 ADVANCE controls the overlay boundary behavior." 226 (let ((overlay (make-overlay start end nil (not advance) advance))) 227 (overlay-put overlay 'evaporate t) 228 (overlay-put overlay 'face 'gptel-context-highlight-face) 229 (overlay-put overlay 'gptel-context t) 230 (push overlay (alist-get (current-buffer) 231 gptel-context--alist)) 232 overlay)) 233 234 ;;;###autoload 235 (defun gptel-context--wrap (message) 236 "Wrap MESSAGE with context string." 237 (funcall gptel-context-wrap-function 238 message (gptel-context--collect))) 239 240 (defun gptel-context--wrap-default (message contexts) 241 "Add CONTEXTS to MESSAGE. 242 243 MESSAGE is usually either the system message or the user prompt. 244 The accumulated context from CONTEXTS is appended or prepended to 245 it, respectively." 246 ;; Append context before/after system message. 247 (let ((context-string (gptel-context--string contexts))) 248 (if (> (length context-string) 0) 249 (pcase-exhaustive gptel-use-context 250 ('system (concat message "\n\n" context-string)) 251 ('user (concat context-string "\n\n" message)) 252 ('nil message)) 253 message))) 254 255 (defun gptel-context--collect-media (&optional contexts) 256 "Collect media CONTEXTS. 257 258 CONTEXTS, which are typically paths to binary files, are 259 base64-encoded and prepended to the first user prompt." 260 (cl-loop for context in (or contexts gptel-context--alist) 261 for (path . props) = context 262 when (and (stringp path) (plist-get props :mime)) 263 collect (cons :media context))) 264 265 (cl-defun gptel-context--add-region (buffer region-beginning region-end &optional advance) 266 "Add region delimited by REGION-BEGINNING, REGION-END in BUFFER as context. 267 268 If ADVANCE is non-nil, the context overlay envelopes changes at 269 the beginning and end." 270 ;; Remove existing contexts in the same region, if any. 271 (mapc #'gptel-context-remove 272 (gptel-context--in-region buffer region-beginning region-end)) 273 (prog1 (with-current-buffer buffer 274 (gptel-context--make-overlay region-beginning region-end advance)) 275 (message "Region added to context buffer."))) 276 277 (defun gptel-context--in-region (buffer start end) 278 "Return the list of context overlays in the given region, if any, in BUFFER. 279 START and END signify the region delimiters." 280 (with-current-buffer buffer 281 (cl-remove-if-not (lambda (ov) (overlay-get ov 'gptel-context)) 282 (overlays-in start end)))) 283 284 (defun gptel-context--at-point () 285 "Return the context overlay at point, if any." 286 (cl-find-if (lambda (ov) (overlay-get ov 'gptel-context)) 287 (overlays-at (point)))) 288 289 ;;;###autoload 290 (defun gptel-context--collect () 291 "Get the list of all active context overlays." 292 ;; Get only the non-degenerate overlays, collect them, and update the overlays variable. 293 (setq gptel-context--alist 294 (cl-loop for (buf . ovs) in gptel-context--alist 295 if (buffer-live-p buf) 296 if (cl-loop for ov in ovs when (overlay-start ov) collect ov) 297 collect (cons buf it) into elements 298 end 299 else if (and (stringp buf) (file-exists-p buf)) 300 if (plist-get ovs :mime) 301 collect (cons buf ovs) into elements 302 else collect (list buf) into elements 303 finally return elements))) 304 305 (defun gptel-context--insert-buffer-string (buffer contexts) 306 "Insert at point a context string from all CONTEXTS in BUFFER." 307 (let ((is-top-snippet t) 308 (previous-line 1)) 309 (insert (format "In buffer `%s`:" (buffer-name buffer)) 310 "\n\n```" (gptel--strip-mode-suffix (buffer-local-value 311 'major-mode buffer)) 312 "\n") 313 (dolist (context contexts) 314 (let* ((start (overlay-start context)) 315 (end (overlay-end context)) 316 content) 317 (let (lineno column) 318 (with-current-buffer buffer 319 (without-restriction 320 (setq lineno (line-number-at-pos start t) 321 column (save-excursion (goto-char start) 322 (current-column)) 323 content (buffer-substring-no-properties start end)))) 324 ;; We do not need to insert a line number indicator if we have two regions 325 ;; on the same line, because the previous region should have already put the 326 ;; indicator. 327 (unless (= previous-line lineno) 328 (unless (= lineno 1) 329 (unless is-top-snippet 330 (insert "\n")) 331 (insert (format "... (Line %d)\n" lineno)))) 332 (setq previous-line lineno) 333 (unless (zerop column) (insert " ...")) 334 (if is-top-snippet 335 (setq is-top-snippet nil) 336 (unless (= previous-line lineno) (insert "\n")))) 337 (insert content))) 338 (unless (>= (overlay-end (car (last contexts))) (point-max)) 339 (insert "\n...")) 340 (insert "\n```"))) 341 342 (defun gptel-context--insert-file-string (path) 343 "Insert at point the contents of the file at PATH as context." 344 (insert (format "In file `%s`:" (file-name-nondirectory path)) 345 "\n\n```\n") 346 (insert-file-contents path) 347 (goto-char (point-max)) 348 (insert "\n```\n")) 349 350 (defun gptel-context--string (context-alist) 351 "Format the aggregated gptel context as annotated markdown fragments. 352 353 Returns a string. CONTEXT-ALIST is a structure containing 354 context overlays, see `gptel-context--alist'." 355 (with-temp-buffer 356 (cl-loop for (buf . ovs) in context-alist 357 if (bufferp buf) 358 do (gptel-context--insert-buffer-string buf ovs) 359 else if (not (plist-get ovs :mime)) 360 do (gptel-context--insert-file-string buf) end 361 do (insert "\n\n") 362 finally do 363 (skip-chars-backward "\n\t\r ") 364 (delete-region (point) (point-max)) 365 (unless (bobp) 366 (goto-char (point-min)) 367 (insert "Request context:\n\n")) 368 finally return 369 (and (> (buffer-size) 0) 370 (buffer-string))))) 371 372 ;;; Major mode for context inspection buffers 373 (defvar-keymap gptel-context-buffer-mode-map 374 "C-c C-c" #'gptel-context-confirm 375 "C-c C-k" #'gptel-context-quit 376 "RET" #'gptel-context-visit 377 "n" #'gptel-context-next 378 "p" #'gptel-context-previous 379 "d" #'gptel-context-flag-deletion) 380 381 (define-derived-mode gptel-context-buffer-mode special-mode "gptel-context" 382 "Major-mode for inspecting context used by gptel." 383 :group 'gptel 384 (add-hook 'post-command-hook #'gptel-context--post-command 385 nil t) 386 (setq-local revert-buffer-function #'gptel-context--buffer-setup)) 387 388 (defun gptel-context--buffer-setup (&optional _ignore-auto _noconfirm) 389 "Set up the gptel context buffer." 390 (with-current-buffer (get-buffer-create "*gptel-context*") 391 (gptel-context-buffer-mode) 392 (let ((inhibit-read-only t)) 393 (erase-buffer) 394 (setq header-line-format 395 (concat 396 (propertize "d" 'face 'help-key-binding) ": Mark/unmark deletion, " 397 (propertize "n" 'face 'help-key-binding) "/" 398 (propertize "p" 'face 'help-key-binding) ": jump to next/previous, " 399 (propertize "C-c C-c" 'face 'help-key-binding) ": apply, " 400 (propertize "C-c C-k" 'face 'help-key-binding) ": cancel, " 401 (propertize "q" 'face 'help-key-binding) ": quit")) 402 (save-excursion 403 (let ((contexts gptel-context--alist)) 404 (if (length> contexts 0) 405 (let (beg ov l1 l2) 406 (pcase-dolist (`(,buf . ,ovs) contexts) 407 (if (bufferp buf) 408 ;; It's a buffer with some overlay(s) 409 (dolist (source-ov ovs) 410 (with-current-buffer buf 411 (setq l1 (line-number-at-pos (overlay-start source-ov)) 412 l2 (line-number-at-pos (overlay-end source-ov)))) 413 (insert (propertize (format "In buffer %s (lines %d-%d):\n\n" 414 (buffer-name buf) l1 l2) 415 'face 'bold)) 416 (setq beg (point)) 417 (insert-buffer-substring 418 buf (overlay-start source-ov) (overlay-end source-ov)) 419 (insert "\n") 420 (setq ov (make-overlay beg (point))) 421 (overlay-put ov 'gptel-context source-ov) 422 (overlay-put ov 'gptel-overlay t) 423 (overlay-put ov 'evaporate t) 424 (insert "\n" (make-separator-line) "\n")) 425 ;; BUF is a file path, not a buffer 426 (insert (propertize (format "In file %s:\n\n" (file-name-nondirectory buf)) 427 'face 'bold)) 428 (setq beg (point)) 429 (if-let ((mime (plist-get ovs :mime))) 430 ;; BUF is a binary file 431 (if-let (((string-match-p (image-file-name-regexp) buf)) 432 (img (create-image buf))) 433 (insert-image img "*") ; Can be displayed 434 (insert 435 buf " " (propertize "(No preview for binary file)" 436 'face '(:inherit shadow :slant italic)))) 437 (insert-file-contents buf)) 438 (goto-char (point-max)) 439 (insert "\n") 440 (setq ov (make-overlay beg (point))) 441 (overlay-put ov 'gptel-context buf) 442 (overlay-put ov 'gptel-overlay t) 443 (overlay-put ov 'evaporate t) 444 (insert "\n" (make-separator-line) "\n"))) 445 (goto-char (point-min))) 446 (insert "There are no active gptel contexts."))))) 447 (display-buffer (current-buffer) 448 `((display-buffer-reuse-window 449 display-buffer-reuse-mode-window 450 display-buffer-below-selected) 451 (body-function . ,#'select-window) 452 (window-height . ,#'fit-window-to-buffer))))) 453 454 (defvar gptel-context--buffer-reverse nil 455 "Last direction of cursor movement in gptel context buffer. 456 457 If non-nil, indicates backward movement.") 458 459 (defalias 'gptel-context--post-command 460 (let ((highlight-overlay)) 461 (lambda () 462 ;; Only update if point moved outside the current region. 463 (unless (memq highlight-overlay (overlays-at (point))) 464 (let ((context-overlay 465 (cl-loop for ov in (overlays-at (point)) 466 thereis (and (overlay-get ov 'gptel-overlay) ov)))) 467 (when highlight-overlay 468 (overlay-put highlight-overlay 'face nil)) 469 (when context-overlay 470 (overlay-put context-overlay 'face 'highlight)) 471 (setq highlight-overlay context-overlay)))))) 472 473 (defun gptel-context-visit () 474 "Display the location of this gptel context chunk in its original buffer." 475 (interactive) 476 (let ((ov-here (car (overlays-at (point))))) 477 (if-let* ((source (overlay-get ov-here 'gptel-context)) 478 (buf (if (overlayp source) 479 (overlay-buffer source) 480 (find-file-noselect source))) 481 (offset (- (point) (overlay-start ov-here)))) 482 (with-selected-window (display-buffer buf) 483 (goto-char (if (overlayp source) 484 (overlay-start source) 485 (point-min))) 486 (forward-char offset) 487 (recenter)) 488 (message "No source location for this gptel context chunk.")))) 489 490 (defun gptel-context-next () 491 "Move to next gptel context chunk." 492 (interactive) 493 (let ((ov-here (car (overlays-at (point)))) 494 (next-start (next-overlay-change (point)))) 495 (when (and (/= (point-max) next-start) ov-here) 496 ;; We were inside the overlay, so we want the next overlay change, which 497 ;; would be the start of the next overlay. 498 (setq next-start (next-overlay-change next-start))) 499 (when (/= next-start (point-max)) 500 (setq gptel-context--buffer-reverse nil) 501 (goto-char next-start) 502 (recenter (floor (window-height) 4))))) 503 504 (defun gptel-context-previous () 505 "Move to previous gptel context chunk." 506 (interactive) 507 (let ((ov-here (car (overlays-at (point))))) 508 (when ov-here (goto-char (overlay-start ov-here))) 509 (let ((previous-context-pos (previous-overlay-change 510 (previous-overlay-change (point))))) 511 ;; Prevent point from jumping to the start of the buffer. 512 (unless (= previous-context-pos (point-min)) 513 (goto-char previous-context-pos) 514 (recenter (floor (window-height) 4)) 515 (setq gptel-context--buffer-reverse t))))) 516 517 (defun gptel-context-flag-deletion () 518 "Mark gptel context chunk at point for removal." 519 (interactive) 520 (let* ((overlays (if (use-region-p) 521 (overlays-in (region-beginning) (region-end)) 522 (overlays-at (point)))) 523 (deletion-ov) 524 (marked-ovs (cl-remove-if-not (lambda (ov) (overlay-get ov 'gptel-context-deletion-mark)) 525 overlays))) 526 (if marked-ovs 527 (mapc #'delete-overlay marked-ovs) 528 (save-excursion 529 (dolist (ov overlays) 530 (when (overlay-get ov 'gptel-context) 531 (goto-char (overlay-start ov)) 532 (setq deletion-ov (make-overlay (overlay-start ov) (overlay-end ov))) 533 (overlay-put deletion-ov 'gptel-context (overlay-get ov 'gptel-context)) 534 (overlay-put deletion-ov 'priority -80) 535 (overlay-put deletion-ov 'face 'gptel-context-deletion-face) 536 (overlay-put deletion-ov 'gptel-context-deletion-mark t))))) 537 (if (use-region-p) 538 (deactivate-mark) 539 (if gptel-context--buffer-reverse 540 (gptel-context-previous) 541 (gptel-context-next))))) 542 543 (defun gptel-context-quit () 544 "Cancel pending operations and return to gptel's menu." 545 (interactive) 546 (quit-window) 547 (call-interactively #'gptel-menu)) 548 549 (defun gptel-context-confirm () 550 "Confirm pending operations and return to gptel's menu." 551 (interactive) 552 ;; Delete all the context overlays that have been marked for deletion. 553 (when-let ((deletion-marks 554 (delq nil (mapcar 555 (lambda (ov) 556 (and 557 (overlay-get ov 'gptel-context-deletion-mark) 558 (overlay-get ov 'gptel-context))) 559 (overlays-in (point-min) (point-max)))))) 560 (mapc #'gptel-context-remove deletion-marks) 561 (gptel-context--collect) ;Update contexts and revert buffer (#482) 562 (revert-buffer)) 563 (gptel-context-quit)) 564 565 (provide 'gptel-context) 566 ;;; gptel-context.el ends here.