misc/fuel/fuel-debug.el

   1 ;;; fuel-debug.el -- debugging factor code
   2
   3 ;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
   4 ;; See http://factorcode.org/license.txt for BSD license.
   5
   6 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
   7 ;; Keywords: languages, fuel, factor
   8 ;; Start date: Sun Dec 07, 2008 04:16
   9
  10 ;;; Comentary:
  11
  12 ;; A mode for displaying the results of run-file and evaluation, with
  13 ;; support for restarts.
  14
  15 ;;; Code:
  16
  17 (require 'fuel-base)
  18 (require 'fuel-eval)
  19 (require 'fuel-font-lock)
  20
  21 \f
  22 ;;; Customization:
  23
  24 (defgroup fuel-debug nil
  25   "Major mode for interaction with the Factor debugger"
  26   :group 'fuel)
  27
  28 (defcustom fuel-debug-mode-hook nil
  29   "Hook run after `fuel-debug-mode' activates"
  30   :group 'fuel-debug
  31   :type 'hook)
  32
  33 (defcustom fuel-debug-show-short-help t
  34   "Whether to show short help on available keys in debugger"
  35   :group 'fuel-debug
  36   :type 'boolean)
  37
  38 (fuel-font-lock--define-faces
  39  fuel-debug-font-lock font-lock fuel-debug
  40  ((error warning "highlighting errors")
  41   (line variable-name "line numbers in errors/warnings")
  42   (column variable-name "column numbers in errors/warnings")
  43   (info comment "information headers")
  44   (restart-number warning "restart numbers")
  45   (restart-name function-name "restart names")))
  46
  47 \f
  48 ;;; Font lock and other pattern matching:
  49
  50 (defconst fuel-debug--compiler-info-alist
  51   '((":warnings" . ?w) (":errors" . ?e) (":linkage" . ?l)))
  52
  53 (defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"")
  54 (defconst fuel-debug--error-line-regex "\\([0-9]+\\):")
  55 (defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$")
  56
  57 (defconst fuel-debug--error-regex
  58   (format "%s\n%s"
  59           fuel-debug--error-file-regex
  60           fuel-debug--error-line-regex))
  61
  62 (defconst fuel-debug--compiler-info-regex
  63   (format "^\\(%s\\) "
  64           (regexp-opt (mapcar 'car fuel-debug--compiler-info-alist))))
  65
  66 (defconst fuel-debug--restart-regex "^:\\([0-9]+\\) \\(.+\\)")
  67
  68 (defconst fuel-debug--font-lock-keywords
  69   `((,fuel-debug--error-file-regex . 'fuel-debug-font-lock-error)
  70     (,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line)
  71     (,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column)
  72     (,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number)
  73                                 (2 'fuel-debug-font-lock-restart-name))
  74     (,fuel-debug--compiler-info-regex 1 'fuel-debug-font-lock-restart-number)
  75     ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info)
  76     ("^Error: " . 'fuel-debug-font-lock-error)))
  77
  78 (defun fuel-debug--font-lock-setup ()
  79   (set (make-local-variable 'font-lock-defaults)
  80        '(fuel-debug--font-lock-keywords t nil nil nil)))
  81
  82 \f
  83 ;;; Debug buffer:
  84
  85 (defvar fuel-debug--buffer nil)
  86
  87 (make-variable-buffer-local
  88  (defvar fuel-debug--last-ret nil))
  89
  90 (make-variable-buffer-local
  91  (defvar fuel-debug--file nil))
  92
  93 (defun fuel-debug--buffer ()
  94   (or (and (buffer-live-p fuel-debug--buffer) fuel-debug--buffer)
  95       (with-current-buffer
  96           (setq fuel-debug--buffer (get-buffer-create "*fuel dbg*"))
  97         (fuel-debug-mode)
  98         (current-buffer))))
  99
 100 (defun fuel-debug--display-retort (ret &optional success-msg no-pop file)
 101   (let ((err (fuel-eval--retort-error ret))
 102         (inhibit-read-only t))
 103     (with-current-buffer (fuel-debug--buffer)
 104       (erase-buffer)
 105       (fuel-debug--display-output ret)
 106       (delete-blank-lines)
 107       (newline)
 108       (when (and (not err) success-msg)
 109         (message "%s" success-msg)
 110         (insert "\n" success-msg "\n"))
 111       (when err
 112         (fuel-debug--display-restarts err)
 113         (delete-blank-lines)
 114         (newline)
 115         (let ((hstr (fuel-debug--help-string err file)))
 116           (if fuel-debug-show-short-help
 117               (insert "-----------\n" hstr "\n")
 118             (message "%s" hstr))))
 119       (setq fuel-debug--last-ret ret)
 120       (setq fuel-debug--file file)
 121       (goto-char (point-max))
 122       (when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer))
 123       (not err))))
 124
 125 (defun fuel-debug--display-output (ret)
 126   (let* ((last (fuel-eval--retort-output fuel-debug--last-ret))
 127          (current (fuel-eval--retort-output ret))
 128          (llen (length last))
 129          (clen (length current))
 130          (trail (and last (substring-no-properties last (/ llen 2))))
 131          (err (fuel-eval--retort-error ret))
 132          (p (point)))
 133     (save-excursion (insert current))
 134     (when (and (> clen llen) (> llen 0) (search-forward trail nil t))
 135       (delete-region p (point)))
 136     (goto-char (point-max))
 137     (when err
 138       (insert (format "\nError: %S\n\n" (fuel-eval--error-name err))))))
 139
 140 (defun fuel-debug--display-restarts (err)
 141   (let* ((rs (fuel-eval--error-restarts err))
 142          (rsn (length rs)))
 143     (when rs
 144       (insert "Restarts:\n\n")
 145       (dotimes (n rsn)
 146         (insert (format ":%s %s\n" (1+ n) (nth n rs))))
 147       (newline))))
 148
 149 (defun fuel-debug--help-string (err &optional file)
 150   (format "Press %s%s%sq bury buffer"
 151           (if (or file (fuel-eval--error-file err)) "g go to file, " "")
 152           (let ((rsn (length (fuel-eval--error-restarts err))))
 153             (cond ((zerop rsn) "")
 154                   ((= 1 rsn) "1 invoke restart, ")
 155                   (t (format "1-%s invoke restarts, " rsn))))
 156           (let ((str ""))
 157             (dolist (ci fuel-debug--compiler-info-alist str)
 158               (save-excursion
 159                 (goto-char (point-min))
 160                 (when (search-forward (car ci) nil t)
 161                   (setq str (format "%c %s, %s" (cdr ci) (car ci) str))))))))
 162
 163 (defun fuel-debug--buffer-file ()
 164   (with-current-buffer (fuel-debug--buffer)
 165     (or fuel-debug--file
 166         (and fuel-debug--last-ret
 167              (fuel-eval--error-file
 168               (fuel-eval--retort-error fuel-debug--last-ret))))))
 169
 170 (defsubst fuel-debug--buffer-error ()
 171   (fuel-eval--retort-error fuel-debug--last-ret))
 172
 173 (defsubst fuel-debug--buffer-restarts ()
 174   (fuel-eval--error-restarts (fuel-debug--buffer-error)))
 175
 176 \f
 177 ;;; Buffer navigation:
 178
 179 (defun fuel-debug-goto-error ()
 180   (interactive)
 181   (let* ((err (or (fuel-debug--buffer-error)
 182                   (error "No errors reported")))
 183          (file (or (fuel-debug--buffer-file)
 184                    (error "No file associated with error")))
 185          (l/c (fuel-eval--error-line/column err))
 186          (line (or (car l/c) 1))
 187          (col (or (cdr l/c) 0)))
 188     (find-file-other-window file)
 189     (goto-line line)
 190     (forward-char col)))
 191
 192 (defun fuel-debug--read-restart-no ()
 193   (let ((rs (fuel-debug--buffer-restarts)))
 194     (unless rs (error "No restarts available"))
 195     (let* ((rsn (length rs))
 196            (prompt (format "Restart number? (1-%s): " rsn))
 197            (no 0))
 198       (while (or (> (setq no (read-number prompt)) rsn)
 199                  (< no 1)))
 200       no)))
 201
 202 (defun fuel-debug-exec-restart (&optional n confirm)
 203   (interactive (list (fuel-debug--read-restart-no)))
 204   (let ((n (or n 1))
 205         (rs (fuel-debug--buffer-restarts)))
 206     (when (zerop (length rs))
 207       (error "No restarts available"))
 208     (when (or (< n 1) (> n (length rs)))
 209       (error "Restart %s not available" n))
 210     (when (or (not confirm)
 211               (y-or-n-p (format "Invoke restart %s? " n)))
 212       (message "Invoking restart %s" n)
 213       (let* ((file (fuel-debug--buffer-file))
 214              (buffer (if file (find-file-noselect file) (current-buffer))))
 215         (with-current-buffer buffer
 216           (fuel-debug--display-retort
 217            (fuel-eval--send/wait `(:fuel ((:factor ,(format ":%s" n)))))
 218            (format "Restart %s (%s) successful" n (nth (1- n) rs))))))))
 219
 220 (defun fuel-debug-show--compiler-info (info)
 221   (save-excursion
 222     (goto-char (point-min))
 223     (unless (re-search-forward (format "^%s" info) nil t)
 224       (error "%s information not available" info))
 225     (message "Retrieving %s info ..." info)
 226     (unless (fuel-debug--display-retort
 227              (fuel-eval--send/wait `(:fuel ((:factor ,info))))
 228              "" (fuel-debug--buffer-file))
 229       (error "Sorry, no %s info available" info))))
 230
 231 \f
 232 ;;; Fuel Debug mode:
 233
 234 (defvar fuel-debug-mode-map
 235   (let ((map (make-keymap)))
 236     (suppress-keymap map)
 237     (define-key map "g" 'fuel-debug-goto-error)
 238     (define-key map "\C-c\C-c" 'fuel-debug-goto-error)
 239     (define-key map "n" 'next-line)
 240     (define-key map "p" 'previous-line)
 241     (define-key map "q" 'bury-buffer)
 242     (dotimes (n 9)
 243       (define-key map (vector (+ ?1 n))
 244         `(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t))))
 245     (dolist (ci fuel-debug--compiler-info-alist)
 246       (define-key map (vector (cdr ci))
 247         `(lambda () (interactive) (fuel-debug-show--compiler-info ,(car ci)))))
 248     map))
 249
 250 (defun fuel-debug-mode ()
 251   "A major mode for displaying Factor's compilation results and
 252 invoking restarts as needed.
 253 \\{fuel-debug-mode-map}"
 254   (interactive)
 255   (kill-all-local-variables)
 256   (buffer-disable-undo)
 257   (setq major-mode 'factor-mode)
 258   (setq mode-name "Fuel Debug")
 259   (use-local-map fuel-debug-mode-map)
 260   (fuel-debug--font-lock-setup)
 261   (setq fuel-debug--file nil)
 262   (setq fuel-debug--last-ret nil)
 263   (setq buffer-read-only t)
 264   (run-hooks 'fuel-debug-mode-hook))
 265
 266 \f
 267 (provide 'fuel-debug)
 268 ;;; fuel-debug.el ends here