1 ;;; geiser-debug.el -- displaying debug information and evaluation results
3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2020 Jose Antonio Ortega Ruiz
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>.
10 ;; Start date: Mon Feb 23, 2009 22:34
15 (require 'geiser-edit
)
16 (require 'geiser-autodoc
)
17 (require 'geiser-impl
)
18 (require 'geiser-eval
)
19 (require 'geiser-menu
)
20 (require 'geiser-popup
)
21 (require 'geiser-base
)
22 (require 'geiser-image
)
27 (defgroup geiser-debug nil
28 "Debugging and error display options."
31 (geiser-custom--defcustom geiser-debug-always-display-sexp-after-p nil
32 "Whether to always display the sexp whose evaluation caused an
33 error after the error message in the debug pop-up. If nil,
34 expressions shorter than `geiser-debug-long-sexp-lines` lines are
35 show before the error message."
39 (geiser-custom--defcustom geiser-debug-long-sexp-lines
6
40 "Length of an expression in order to be relegated to the bottom
41 of the debug pop-up (after the error message). If
42 `geiser-debug-always-display-sexp-after-p` is t, this variable
47 (geiser-custom--defcustom geiser-debug-jump-to-debug-p t
48 "When set to t (the default), jump to the debug pop-up buffer
49 in case of evaluation errors.
51 See also `geiser-debug-show-debug-p`. "
55 (geiser-custom--defcustom geiser-debug-show-debug-p t
56 "When set to t (the default), show the debug pop-up buffer in
57 case of evaluation errors.
59 This option takes effect even if `geiser-debug-jump-to-debug-p`
64 (geiser-custom--defcustom geiser-debug-auto-display-images-p t
65 "Whether to automatically invoke the external viewer to display
66 images when they're evaluated.
68 See also `geiser-repl-auto-display-images-p'."
73 ;;; Debug buffer mode:
75 (defvar geiser-debug-mode-map
76 (let ((map (make-sparse-keymap)))
78 (set-keymap-parent map button-buffer-map
)
80 "Keymap for `geiser-debug-mode'.")
82 (define-derived-mode geiser-debug-mode nil
"Geiser DBG"
83 "A major mode for displaying Scheme compilation and evaluation results.
84 \\{geiser-debug-mode-map}"
86 (set-syntax-table scheme-mode-syntax-table
)
87 (setq next-error-function
'geiser-edit--open-next
)
88 (setq buffer-read-only t
))
90 (defun geiser-debug--button-p (nextp)
91 (let ((m (funcall (if nextp
'next-button
'previous-button
) (point))))
92 (and m
(funcall (if nextp
'< '>) (point) (marker-position m
)))))
94 (geiser-menu--defmenu debug geiser-debug-mode-map
95 ("Next error" "n" forward-button
:enable
(geiser-debug--button-p t
))
96 ("Previous error" "p" backward-button
:enable
(geiser-debug--button-p t
))
98 ("Quit" nil View-quit
))
101 ;;; Buffer for displaying evaluation results:
103 (geiser-popup--define debug
"*Geiser dbg*" geiser-debug-mode
)
106 ;;; Displaying retorts
108 (geiser-impl--define-caller geiser-debug--display-error
109 display-error
(module key message
)
110 "This method takes 3 parameters (a module name, the error key,
111 and the accompanying error message) and should display
112 (in the current buffer) a formatted version of the error. If the
113 error was successfully displayed, the call should evaluate to a
116 (geiser-impl--define-caller geiser-debug--enter-debugger
118 "This method is called upon entering the debugger, in the REPL
121 (defun geiser-debug--display-after (what)
122 (or geiser-debug-always-display-sexp-after-p
123 (>= (with-temp-buffer
125 (count-lines (point-min) (point-max)))
126 geiser-debug-long-sexp-lines
)))
128 (defun geiser-debug--insert-res (res)
129 (let ((begin (point)))
133 (let ((no (geiser-image--replace-images
134 t geiser-debug-auto-display-images-p
)))
137 (and no
(> no
0))))))
139 (defun geiser-debug--display-retort (what ret
&optional res auto-p
)
140 (let* ((err (geiser-eval--retort-error ret
))
141 (key (geiser-eval--error-key err
))
142 (output (geiser-eval--retort-output ret
))
143 (impl geiser-impl--implementation
)
144 (module (geiser-eval--get-module))
147 (dir default-directory
)
148 (buffer (current-buffer))
149 (debug (eq key
'geiser-debugger
))
150 (after (geiser-debug--display-after what
)))
152 (switch-to-geiser nil nil buffer
)
153 (geiser-debug--enter-debugger impl
))
154 (geiser-debug--with-buffer
156 (when dir
(setq default-directory dir
))
158 (geiser-debug--display-error impl module nil what
)
159 (goto-char (point-max))
161 (setq img
(when (and res
(not err
)) (geiser-debug--insert-res res
)))
162 (setq dbg
(geiser-debug--display-error impl module key output
))
164 (goto-char (point-max))
165 (insert "\nExpression evaluated was:\n\n")
166 (geiser-debug--display-error impl module nil what
))
167 (goto-char (point-min)))
169 (when (or geiser-debug-jump-to-debug-p geiser-debug-show-debug-p
)
170 (if geiser-debug-jump-to-debug-p
171 (geiser-debug--pop-to-buffer)
172 (display-buffer (geiser-debug--buffer))
174 (ignore-errors (next-error))
175 (message "=> %s" dbg
)))))))
177 (defsubst geiser-debug--wrap-region
(str)
178 (format "(begin %s\n)" str
))
180 (defun geiser-debug--unwrap (str)
181 (if (string-match "(begin[ \t\n\v\r]+\\(.+\\)*)" str
)
185 (defun geiser-debug--send-region (compile start end and-go wrap
&optional nomsg
)
186 (let* ((str (buffer-substring-no-properties start end
))
187 (wrapped (if wrap
(geiser-debug--wrap-region str
) str
))
188 (code `(,(if compile
:comp
:eval
) (:scm
,wrapped
)))
189 (ret (geiser-eval--send/wait code
))
190 (res (geiser-eval--retort-result-str ret nil
))
191 (err (geiser-eval--retort-error ret
)))
192 (when and-go
(funcall and-go
))
195 (goto-char (/ (+ end start
) 2))
196 (geiser-autodoc--clean-cache))
199 (when (string-match "\\(?:[ \t\n\r]+\\)\\'" res
)
200 (setq res
(replace-match "" t t res
))))
202 (geiser-debug--display-retort (geiser-syntax--scheme-str str
) ret res
)
205 (defun geiser-debug--expand-region (start end all wrap
)
206 (let* ((str (buffer-substring-no-properties start end
))
207 (wrapped (if wrap
(geiser-debug--wrap-region str
) str
))
208 (code `(:eval
(:ge macroexpand
(quote (:scm
,wrapped
))
210 (ret (geiser-eval--send/wait code
))
211 (err (geiser-eval--retort-error ret
))
212 (result (geiser-eval--retort-result ret
)))
214 (geiser-debug--display-retort str ret
)
215 (geiser-debug--with-buffer
217 (insert (format "%s" (if wrap
(geiser-debug--unwrap result
) result
)))
218 (goto-char (point-min)))
219 (geiser-debug--pop-to-buffer))))
222 (provide 'geiser-debug
)