geiser-debug.el (11857B)
1 ;;; geiser-debug.el -- displaying debug and eval info -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2009-2016, 2020-2022 Jose Antonio Ortega Ruiz 4 5 ;; This program is free software; you can redistribute it and/or 6 ;; modify it under the terms of the Modified BSD License. You should 7 ;; have received a copy of the license along with this program. If 8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. 9 10 ;; Start date: Mon Feb 23, 2009 22:34 11 12 13 ;;; Code: 14 15 (eval-when-compile (require 'cl-macs)) 16 17 (require 'geiser-edit) 18 (require 'geiser-autodoc) 19 (require 'geiser-impl) 20 (require 'geiser-eval) 21 (require 'geiser-menu) 22 (require 'geiser-popup) 23 (require 'geiser-base) 24 (require 'geiser-image) 25 26 (require 'ansi-color) 27 (require 'compile) 28 29 (declare-function geiser-repl--switch-to-buffer "geiser-repl" (buffer)) 30 31 32 ;;; Customization: 33 34 (defgroup geiser-debug nil 35 "Debugging and error display options." 36 :group 'geiser) 37 38 (define-obsolete-variable-alias 'geiser-debug-always-display-sexp-after-p 39 'geiser-debug-always-display-sexp-after "0.26.2") 40 41 (geiser-custom--defcustom geiser-debug-always-display-sexp-after nil 42 "Whether to always display the sexp whose evaluation caused an 43 error after the error message in the debug pop-up. 44 45 If nil, expressions shorter than `geiser-debug-long-sexp-lines` 46 lines are shown before the error message." 47 :type 'boolean) 48 49 (geiser-custom--defcustom geiser-debug-long-sexp-lines 6 50 "Length of an expression in order to be relegated to the bottom 51 of the debug pop-up (after the error message). 52 53 If `geiser-debug-always-display-sexp-after` is t, this variable 54 has no effect." 55 :type 'int) 56 57 (define-obsolete-variable-alias 'geiser-debug-jump-to-debug-p 58 'geiser-debug-jump-to-debug "0.26.2") 59 60 (geiser-custom--defcustom geiser-debug-jump-to-debug t 61 "When set to t (the default), jump to the debug pop-up buffer 62 in case of evaluation errors. 63 64 See also `geiser-debug-show-debug`. " 65 :type 'boolean) 66 67 (define-obsolete-variable-alias 'geiser-debug-show-debug-p 68 'geiser-debug-show-debug "0.26.2") 69 70 (geiser-custom--defcustom geiser-debug-auto-next-error-p nil 71 "When set, automatically invoke `next-error' on of evaluation errors. 72 73 This will make point jump to the location of an error if the output 74 of the evaluation contains any." 75 :type 'boolean) 76 77 (geiser-custom--defcustom geiser-debug-show-debug t 78 "When set to t (the default), show the debug pop-up buffer in 79 case of evaluation errors. 80 81 This option takes effect even if `geiser-debug-jump-to-debug` 82 is set." 83 :type 'boolean) 84 85 (define-obsolete-variable-alias 'geiser-debug-auto-display-images-p 86 'geiser-debug-auto-display-images "0.26.2") 87 88 (geiser-custom--defcustom geiser-debug-auto-display-images t 89 "Whether to automatically invoke the external viewer to display 90 images when they're evaluated. 91 92 See also `geiser-repl-auto-display-images-p'." 93 :type 'boolean) 94 95 (geiser-custom--defcustom geiser-debug-treat-ansi-colors nil 96 "Colorize ANSI escape sequences produced by the scheme process. 97 98 Some schemes are able to colorize their evaluation or error 99 results using ANSI color sequences (e.g. when using the the 100 colorized module in Guile). 101 102 If set to `nil', no special treatment is applied to output. The 103 symbol colors indicates colorizing the display of the Geiser debug 104 buffer using any color escape, and the symbol remove to remove 105 all ANSI sequences." 106 :type '(choice (const :tag "No special treatment" nil) 107 (const :tag "Use font lock for colors" colors) 108 (const :tag "Remove all ANSI codes" remove))) 109 110 111 ;;; Debug buffer mode: 112 113 (defvar geiser-debug-mode-map 114 (let ((map (make-sparse-keymap))) 115 (suppress-keymap map) 116 map) 117 "Keymap for `geiser-debug-mode'.") 118 119 (define-derived-mode geiser-debug-mode nil "Geiser Debug" 120 "A major mode for displaying Scheme compilation and evaluation results. 121 \\{geiser-debug-mode-map}" 122 (buffer-disable-undo) 123 (set-syntax-table scheme-mode-syntax-table) 124 (setq next-error-function 'geiser-edit--open-next) 125 (compilation-setup nil) 126 (setq buffer-read-only t)) 127 128 (defvar-local geiser-debug--debugger-active nil) 129 (defvar-local geiser-debug--sender-buffer nil) 130 131 (defun geiser-debug-active-p () 132 "Check whether debugger has been entered by a scheme buffer operation." 133 (and geiser-debug--debugger-active geiser-debug--sender-buffer)) 134 135 (defun geiser-debug-switch-to-buffer () 136 "Return to the scheme buffer that pooped this debug window." 137 (interactive) 138 (when geiser-debug--sender-buffer 139 (geiser-repl--switch-to-buffer geiser-debug--sender-buffer))) 140 141 (geiser-menu--defmenu debug geiser-debug-mode-map 142 ("Next error" ("n" [?\t]) compilation-next-error) 143 ("Previous error" ("p" "\e\t" [backtab]) compilation-previous-error) 144 ("Next error location" ((kbd "M-n")) next-error) 145 ("Previous error location" ((kbd "M-p")) previous-error) 146 ("Source buffer" ("z" (kbd "C-c C-z")) geiser-debug-switch-to-buffer) 147 -- 148 ("Quit" nil View-quit)) 149 150 151 ;;; Implementation-dependent functionality 152 (geiser-impl--define-caller geiser-debug--clean-up-output clean-up-output (output) 153 "Clean up output from an evaluation for display.") 154 155 156 ;;; Buffer for displaying evaluation results: 157 158 (geiser-popup--define debug "*Geiser Debug*" geiser-debug-mode) 159 160 161 ;;; Displaying retorts 162 163 (geiser-impl--define-caller geiser-debug--display-error 164 display-error (module key message) 165 "This method takes 3 parameters (a module name, the error key, 166 and the accompanying error message) and should display 167 (in the current buffer) a formatted version of the error. If the 168 error was successfully displayed, the call should evaluate to a 169 non-null value.") 170 171 (geiser-impl--define-caller geiser-debug--enter-debugger 172 enter-debugger () 173 "This method is called upon entering the debugger, in the REPL 174 buffer.") 175 176 (defun geiser-debug--display-after (what) 177 (or geiser-debug-always-display-sexp-after 178 (>= (with-temp-buffer 179 (insert what) 180 (count-lines (point-min) (point-max))) 181 geiser-debug-long-sexp-lines))) 182 183 (defun geiser-debug--insert-res (res) 184 (let ((begin (point))) 185 (insert res) 186 (let ((end (point))) 187 (goto-char begin) 188 (let ((no (geiser-image--replace-images t 189 geiser-debug-auto-display-images))) 190 (goto-char end) 191 (newline 2) 192 (and no (> no 0)))))) 193 194 (defun geiser-debug--default-display-error (key msg) 195 (insert "\n" 196 (if key (format "Error: %s\n" key) "") 197 (format "%s" (or msg "")) "\n")) 198 199 (defun geiser-debug--display-retort (what ret &optional res _auto-p) 200 (let* ((err (geiser-eval--retort-error ret)) 201 (key (geiser-eval--error-key err)) 202 (debug (alist-get 'debug ret)) 203 (impl geiser-impl--implementation) 204 (output (geiser-eval--retort-output ret)) 205 (output (and (stringp output) 206 (not (string= output "")) 207 (or (geiser-debug--clean-up-output impl output) output))) 208 (module (geiser-eval--get-module)) 209 (img nil) 210 (dir default-directory) 211 (buffer (current-buffer)) 212 (debug-entered (when debug (geiser-debug--enter-debugger impl))) 213 (after (geiser-debug--display-after what))) 214 (unless debug-entered 215 (geiser-debug--with-buffer 216 (when (and (not debug) geiser-debug--debugger-active) 217 (message "Debugger exited")) 218 (setq geiser-debug--debugger-active debug 219 geiser-debug--sender-buffer buffer 220 geiser-impl--implementation impl) 221 (erase-buffer) 222 (when dir (setq default-directory dir)) 223 (unless after (insert what "\n\n")) 224 (setq img (when (and res (not err) (not debug)) 225 (geiser-debug--insert-res res))) 226 (when (or err key output) 227 (when (fboundp 'next-error-select-buffer) 228 (next-error-select-buffer (current-buffer))) 229 (let ((msg (or (geiser-eval--error-msg err) output ""))) 230 (or (geiser-debug--display-error impl module key msg) 231 (geiser-debug--default-display-error key msg)) 232 (unless err (geiser-edit--buttonize-files)))) 233 (when after 234 (goto-char (point-max)) 235 (insert "\nExpression evaluated was:\n\n") 236 (insert what "\n")) 237 (cl-case geiser-debug-treat-ansi-colors 238 (colors (ansi-color-apply-on-region (point-min) (point-max))) 239 (remove (ansi-color-filter-region (point-min) (point-max)))) 240 (goto-char (point-min))) 241 (when (or img err output) 242 (cond (geiser-debug-jump-to-debug 243 (geiser-debug--pop-to-buffer)) 244 (geiser-debug-show-debug 245 (display-buffer (geiser-debug--buffer)))) 246 (when (and err geiser-debug-auto-next-error-p) 247 (ignore-errors (next-error)) 248 (message "=> %s" output)))))) 249 250 (defsubst geiser-debug--wrap-region (str) 251 (format "(begin %s\n)" str)) 252 253 (defun geiser-debug--unwrap (str) 254 (if (string-match "(begin[ \t\n\v\r]+\\(.+\\)*)" str) 255 (match-string 1 str) 256 str)) 257 258 (defun geiser-debug--send-region (compile start end and-go wrap &optional nomsg) 259 "Evaluate (or COMPILE) the region delimited by START and END. 260 The result of the evaluation is reported asynchronously, so this 261 call is not blocking. If AND-GO is t, also jump to the repl 262 buffer. If WRAP is t, the region's content is wrapped in a begin 263 form. The flag NOMSG can be used to avoid reporting of the 264 result in the minibuffer." 265 (let* ((str (buffer-substring-no-properties start end)) 266 (wrapped (if wrap (geiser-debug--wrap-region str) str)) 267 (code `(,(if compile :comp :eval) (:scm ,wrapped))) 268 (cont (lambda (ret) 269 (let ((res (geiser-eval--retort-result-str ret nil)) 270 (scstr (geiser-syntax--scheme-str str))) 271 (when and-go (funcall and-go)) 272 (unless (geiser-eval--retort-error ret) 273 (save-excursion 274 (goto-char (/ (+ end start) 2)) 275 (geiser-autodoc--clean-cache)) 276 (unless nomsg 277 (save-match-data 278 (when (string-match "\\(?:[ \t\n\r]+\\)\\'" res) 279 (setq res (replace-match "" t t res)))) 280 (message "%s" res))) 281 (geiser-debug--display-retort scstr ret res))))) 282 (geiser-eval--send code cont (current-buffer)))) 283 284 (defun geiser-debug--send-region/wait (compile start end timeout) 285 "Synchronous version of `geiser-debug--send-region', returning its result." 286 (let* ((str (buffer-substring-no-properties start end)) 287 (wrapped (geiser-debug--wrap-region str)) 288 (code `(,(if compile :comp :eval) (:scm ,wrapped)))) 289 (message "evaluating: %s" code) 290 (geiser-eval--send/wait code timeout))) 291 292 (defun geiser-debug--expand-region (start end all wrap) 293 (let* ((str (buffer-substring-no-properties start end)) 294 (wrapped (if wrap (geiser-debug--wrap-region str) str)) 295 (code 296 `(:eval (:ge macroexpand (quote (:scm ,wrapped)) ,(if all :t :f)))) 297 (cont (lambda (ret) 298 (let ((err (geiser-eval--retort-error ret)) 299 (result (geiser-eval--retort-result ret))) 300 (if err 301 (geiser-debug--display-retort str ret) 302 (geiser-debug--with-buffer 303 (erase-buffer) 304 (insert (format "%s" 305 (if wrap 306 (geiser-debug--unwrap result) 307 result))) 308 (goto-char (point-min))) 309 (geiser-debug--pop-to-buffer)))))) 310 (geiser-eval--send code cont (current-buffer)))) 311 312 313 (provide 'geiser-debug)