elisp/geiser-debug.el

   1 ;;; geiser-debug.el -- displaying debug information and evaluation results
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2012 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 \f
  13
  14 (require 'geiser-edit)
  15 (require 'geiser-autodoc)
  16 (require 'geiser-impl)
  17 (require 'geiser-eval)
  18 (require 'geiser-menu)
  19 (require 'geiser-popup)
  20 (require 'geiser-base)
  21
  22 \f
  23 ;;; Customization:
  24
  25 (defgroup geiser-debug nil
  26   "Debugging and error display options."
  27   :group 'geiser)
  28
  29 (geiser-custom--defcustom geiser-debug-always-display-sexp-after-p nil
  30   "Whether to always display the sexp whose evaluation caused an
  31 error after the error message in the debug pop-up. If nil,
  32 expressions shorter than `geiser-debug-long-sexp-lines` lines are
  33 show before the error message."
  34   :group 'geiser-debug
  35   :type 'boolean)
  36
  37 (geiser-custom--defcustom geiser-debug-long-sexp-lines 6
  38   "Length of an expression in order to be relegated to the bottom
  39 of the debug pop-up (after the error message). If
  40 `geiser-debug-always-display-sexp-after-p` is t, this variable
  41 has no effect."
  42   :group 'geiser-debug
  43   :type 'int)
  44
  45
  46 (geiser-custom--defcustom geiser-debug-auto-display-images-p t
  47   "Whether to automatically invoke the external viewer to display
  48 images when they're evaluated.
  49
  50 See also `geiser-repl-auto-display-images-p'."
  51   :group 'geiser-debug
  52   :type 'boolean)
  53
  54 \f
  55 ;;; Debug buffer mode:
  56
  57 (defvar geiser-debug-mode-map
  58   (let ((map (make-sparse-keymap)))
  59     (suppress-keymap map)
  60     (set-keymap-parent map button-buffer-map)
  61     map))
  62
  63 (defun geiser-debug-mode ()
  64   "A major mode for displaying Scheme compilation and evaluation results.
  65 \\{geiser-debug-mode-map}"
  66   (interactive)
  67   (kill-all-local-variables)
  68   (buffer-disable-undo)
  69   (use-local-map geiser-debug-mode-map)
  70   (set-syntax-table scheme-mode-syntax-table)
  71   (setq mode-name "Geiser DBG")
  72   (setq major-mode 'geiser-debug-mode)
  73   (setq next-error-function 'geiser-edit--open-next)
  74   (setq buffer-read-only t))
  75
  76 (defun geiser-debug--button-p (nextp)
  77   (let ((m (funcall (if nextp 'next-button 'previous-button) (point))))
  78     (and m (funcall (if nextp '< '>) (point) (marker-position m)))))
  79
  80 (geiser-menu--defmenu debug geiser-debug-mode-map
  81   ("Next error" "n" forward-button :enable (geiser-debug--button-p t))
  82   ("Previous error" "p" backward-button :enable (geiser-debug--button-p t))
  83   --
  84   ("Quit" nil View-quit))
  85
  86 \f
  87 ;;; Buffer for displaying evaluation results:
  88
  89 (geiser-popup--define debug "*Geiser dbg*" geiser-debug-mode)
  90
  91 \f
  92 ;;; Displaying retorts
  93
  94 (geiser-impl--define-caller geiser-debug--display-error
  95     display-error (module key message)
  96     "This method takes 3 parameters (a module name, the error key,
  97 and the accompanying error message) and should display
  98 (in the current buffer) a formatted version of the error. If the
  99 error was successfully displayed, the call should evaluate to a
 100 non-null value.")
 101
 102 (geiser-impl--define-caller geiser-debug--enter-debugger
 103     enter-debugger ()
 104   "This method is called upon entering the debugger, in the REPL
 105 buffer.")
 106
 107 (defun geiser-debug--display-after (what)
 108   (or geiser-debug-always-display-sexp-after-p
 109       (>= (with-temp-buffer
 110             (insert what)
 111             (count-lines (point-min) (point-max)))
 112           geiser-debug-long-sexp-lines)))
 113
 114 (defun geiser-debug--insert-res (res)
 115   (let ((begin (point)))
 116     (insert res)
 117     (let ((end (point)))
 118       (goto-char begin)
 119       (let ((no
 120              (geiser-image--replace-images t
 121                                            geiser-debug-auto-display-images-p)))
 122         (goto-char end)
 123         (newline 2)
 124         (and no (> no 0))))))
 125
 126 (defun geiser-debug--display-retort (what ret &optional res auto-p)
 127   (let* ((err (geiser-eval--retort-error ret))
 128          (key (geiser-eval--error-key err))
 129          (output (geiser-eval--retort-output ret))
 130          (impl geiser-impl--implementation)
 131          (module (geiser-eval--get-module))
 132          (dbg nil)
 133          (img nil)
 134          (dir default-directory)
 135          (buffer (current-buffer))
 136          (debug (eq key 'geiser-debugger))
 137          (after (geiser-debug--display-after what)))
 138     (when debug
 139       (switch-to-geiser nil nil buffer)
 140       (geiser-debug--enter-debugger impl))
 141     (geiser-debug--with-buffer
 142       (erase-buffer)
 143       (when dir (setq default-directory dir))
 144       (unless after
 145         (geiser-debug--display-error impl module nil what)
 146         (newline 2))
 147       (setq img (when (and res (not err)) (geiser-debug--insert-res res)))
 148       (setq dbg (geiser-debug--display-error impl module key output))
 149       (when after
 150         (goto-char (point-max))
 151         (insert "\nExpression evaluated was:\n\n")
 152         (geiser-debug--display-error impl module nil what))
 153       (goto-char (point-min)))
 154     (when (or img dbg) (geiser-debug--pop-to-buffer))))
 155
 156 (defsubst geiser-debug--wrap-region (str)
 157   (format "(begin %s)" str))
 158
 159 (defun geiser-debug--unwrap (str)
 160   (if (string-match "(begin[ \t\n\v\r]+\\(.+\\)*)" str)
 161       (match-string 1 str)
 162     str))
 163
 164 (defun geiser-debug--send-region (compile start end and-go wrap)
 165   (let* ((str (buffer-substring-no-properties start end))
 166          (wrapped (if wrap (geiser-debug--wrap-region str) str))
 167          (code `(,(if compile :comp :eval) (:scm ,wrapped)))
 168          (ret (geiser-eval--send/wait code))
 169          (res (geiser-eval--retort-result-str ret))
 170          (err (geiser-eval--retort-error ret)))
 171     (when and-go (funcall and-go))
 172     (when (not err)
 173       (save-excursion
 174         (goto-char (/ (+ end start) 2))
 175         (geiser-autodoc--clean-cache))
 176       (message "%s" res))
 177     (geiser-debug--display-retort (geiser-syntax--scheme-str str) ret res)))
 178
 179 (defun geiser-debug--expand-region (start end all wrap)
 180   (let* ((str (buffer-substring-no-properties start end))
 181          (wrapped (if wrap (geiser-debug--wrap-region str) str))
 182          (code `(:eval (:ge macroexpand (quote (:scm ,wrapped))
 183                             ,(if all :t :f))))
 184          (ret (geiser-eval--send/wait code))
 185          (err (geiser-eval--retort-error ret))
 186          (result (geiser-eval--retort-result ret)))
 187     (if err
 188         (geiser-debug--display-retort str ret)
 189       (geiser-debug--with-buffer
 190         (erase-buffer)
 191         (insert (format "%s" (if wrap (geiser-debug--unwrap result) result)))
 192         (goto-char (point-min)))
 193       (geiser-debug--pop-to-buffer))))
 194
 195 \f
 196 (provide 'geiser-debug)