/misc/fuel/fuel-debug.el

  1;;; fuel-debug.el -- debugging factor code
  2
  3;; Copyright (C) 2008, 2009, 2010 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-eval)
 18(require 'fuel-popup)
 19(require 'fuel-font-lock)
 20(require 'fuel-menu)
 21(require 'fuel-base)
 22
 23
 24;;; Customization:
 25
 26(defgroup fuel-debug nil
 27  "Major mode for interaction with the Factor debugger."
 28  :group 'fuel)
 29
 30(defcustom fuel-debug-mode-hook nil
 31  "Hook run after `fuel-debug-mode' activates."
 32  :group 'fuel-debug
 33  :type 'hook)
 34
 35(defcustom fuel-debug-confirm-restarts-p t
 36  "Whether to ask for confimation before executing a restart in
 37the debugger."
 38  :group 'fuel-debug
 39  :type 'boolean)
 40
 41(defcustom fuel-debug-show-short-help t
 42  "Whether to show short help on available keys in debugger."
 43  :group 'fuel-debug
 44  :type 'boolean)
 45
 46(fuel-font-lock--define-faces
 47 fuel-font-lock-debug font-lock fuel-debug
 48 ((error warning "highlighting errors")
 49  (line variable-name "line numbers in errors/warnings")
 50  (column variable-name "column numbers in errors/warnings")
 51  (info comment "information headers")
 52  (restart-number warning "restart numbers")
 53  (restart-name function-name "restart names")
 54  (missing-vocab warning"missing vocabulary names")
 55  (unneeded-vocab warning "unneeded vocabulary names")))
 56
 57
 58;;; Font lock and other pattern matching:
 59
 60(defconst fuel-debug--compiler-info-alist
 61  '((":warnings" . ?w) (":errors" . ?e) (":linkage" . ?l)))
 62
 63(defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"")
 64(defconst fuel-debug--error-line-regex "\\([0-9]+\\):")
 65(defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$")
 66
 67(defconst fuel-debug--error-regex
 68  (format "%s\n%s"
 69          fuel-debug--error-file-regex
 70          fuel-debug--error-line-regex))
 71
 72(defconst fuel-debug--compiler-info-regex
 73  (format "^\\(%s\\) "
 74          (regexp-opt (mapcar 'car fuel-debug--compiler-info-alist))))
 75
 76(defconst fuel-debug--restart-regex "^:\\([0-9]+\\) \\(.+\\)")
 77
 78(defconst fuel-debug--font-lock-keywords
 79  `((,fuel-debug--error-file-regex . 'fuel-font-lock-debug-error)
 80    (,fuel-debug--error-line-regex 1 'fuel-font-lock-debug-line)
 81    (,fuel-debug--error-cont-regex 1 'fuel-font-lock-debug-column)
 82    (,fuel-debug--restart-regex (1 'fuel-font-lock-debug-restart-number)
 83                                (2 'fuel-font-lock-debug-restart-name))
 84    (,fuel-debug--compiler-info-regex 1 'fuel-font-lock-debug-restart-number)
 85    ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-font-lock-debug-info)
 86    ("^Error: " . 'fuel-font-lock-debug-error)))
 87
 88(defun fuel-debug--font-lock-setup ()
 89  (set (make-local-variable 'font-lock-defaults)
 90       '(fuel-debug--font-lock-keywords t nil nil nil)))
 91
 92
 93;;; Debug buffer:
 94
 95(fuel-popup--define fuel-debug--buffer
 96  "*fuel debug*" 'fuel-debug-mode)
 97
 98(make-variable-buffer-local
 99 (defvar fuel-debug--last-ret nil))
100
101(make-variable-buffer-local
102 (defvar fuel-debug--file nil))
103
104(make-variable-buffer-local
105 (defvar fuel-debug--uses nil))
106
107(defun fuel-debug--prepare-compilation (file msg)
108  (let ((inhibit-read-only t))
109    (with-current-buffer (fuel-debug--buffer)
110      (erase-buffer)
111      (insert msg)
112      (setq fuel-debug--file file))))
113
114(defun fuel-debug--display-retort (ret &optional success-msg no-pop)
115  (let ((err (fuel-eval--retort-error ret))
116        (inhibit-read-only t))
117    (with-current-buffer (fuel-debug--buffer)
118      (erase-buffer)
119      (fuel-debug--display-output ret)
120      (delete-blank-lines)
121      (newline)
122      (when (and (not err) success-msg)
123        (message "%s" success-msg)
124        (insert "\n" success-msg "\n"))
125      (when err
126        (fuel-debug--display-restarts err)
127        (delete-blank-lines)
128        (newline))
129      (fuel-debug--display-uses ret)
130      (let ((hstr (fuel-debug--help-string err fuel-debug--file)))
131        (if fuel-debug-show-short-help
132            (insert "-----------\n" hstr "\n")
133          (message "%s" hstr)))
134      (setq fuel-debug--last-ret ret)
135      (goto-char (point-max))
136      (font-lock-fontify-buffer)
137      (when (and err (not no-pop)) (fuel-popup--display))
138      (not err))))
139
140(defun fuel-debug--uses (ret)
141  (let ((uses (fuel-eval--retort-result ret)))
142    (and (eq :uses (car uses))
143         (cdr uses))))
144
145(defun fuel-debug--insert-vlist (title vlist)
146  (goto-char (point-max))
147  (insert title "\n\n  ")
148  (let ((i 0) (step 5))
149    (dolist (v vlist)
150      (setq i (1+ i))
151      (insert v)
152      (insert (if (zerop (mod i step)) "\n  " " ")))
153    (unless (zerop (mod i step)) (newline))
154    (newline)))
155
156(defun fuel-debug--highlight-names (names ref face)
157  (dolist (n names)
158    (when (not (member n ref))
159      (put-text-property 0 (length n) 'font-lock-face face n))))
160
161(defun fuel-debug--insert-uses (uses)
162  (let* ((file (or file fuel-debug--file))
163         (old (with-current-buffer (find-file-noselect file)
164                (sort (fuel-syntax--find-usings t) 'string<)))
165         (new (sort uses 'string<)))
166    (when (not (equalp old new))
167      (fuel-debug--highlight-names old new 'fuel-font-lock-debug-unneeded-vocab)
168      (newline)
169      (fuel-debug--insert-vlist "Correct vocabulary list:" new)
170      new)))
171
172(defun fuel-debug--display-uses (ret)
173  (when (setq fuel-debug--uses (fuel-debug--uses ret))
174    (newline)
175    (fuel-debug--highlight-names fuel-debug--uses
176                                 nil 'fuel-font-lock-debug-missing-vocab)
177    (fuel-debug--insert-vlist "Missing vocabularies:" fuel-debug--uses)
178    (newline)))
179
180(defun fuel-debug--display-output (ret)
181  (let* ((last (fuel-eval--retort-output fuel-debug--last-ret))
182         (current (fuel-eval--retort-output ret))
183         (llen (length last))
184         (clen (length current))
185         (trail (and last (substring-no-properties last (/ llen 2))))
186         (err (fuel-eval--retort-error ret))
187         (p (point)))
188    (when current (save-excursion (insert current)))
189    (when (and (> clen llen) (> llen 0) (search-forward trail nil t))
190      (delete-region p (point)))
191    (goto-char (point-max))
192    (when err
193      (insert (format "\nError: %S\n\n" (fuel-eval--error-name err))))))
194
195(defun fuel-debug--display-restarts (err)
196  (let* ((rs (fuel-eval--error-restarts err))
197         (rsn (length rs)))
198    (when rs
199      (insert "Restarts:\n\n")
200      (dotimes (n rsn)
201        (insert (format ":%s %s\n" (1+ n) (nth n rs))))
202      (newline))))
203
204(defun fuel-debug--help-string (err &optional file)
205  (format "Press %s%s%s%sq bury buffer"
206          (if (or file (fuel-eval--error-file err)) "g go to file, " "")
207          (let ((rsn (length (fuel-eval--error-restarts err))))
208            (cond ((zerop rsn) "")
209                  ((= 1 rsn) "1 invoke restart, ")
210                  (t (format "1-%s invoke restarts, " rsn))))
211          (let ((str ""))
212            (dolist (ci fuel-debug--compiler-info-alist str)
213              (save-excursion
214                (goto-char (point-min))
215                (when (search-forward (car ci) nil t)
216                  (setq str (format "%c %s, %s" (cdr ci) (car ci) str))))))
217          (if fuel-debug--uses "u to update USING:, " "")))
218
219(defun fuel-debug--buffer-file ()
220  (with-current-buffer (fuel-debug--buffer)
221    (or fuel-debug--file
222        (and fuel-debug--last-ret
223             (fuel-eval--error-file
224              (fuel-eval--retort-error fuel-debug--last-ret))))))
225
226(defsubst fuel-debug--buffer-error ()
227  (fuel-eval--retort-error fuel-debug--last-ret))
228
229(defsubst fuel-debug--buffer-restarts ()
230  (fuel-eval--error-restarts (fuel-debug--buffer-error)))
231
232
233;;; Buffer navigation:
234
235(defun fuel-debug-goto-error ()
236  (interactive)
237  (let* ((err (fuel-debug--buffer-error))
238         (file (or (fuel-debug--buffer-file)
239                   (error "No file associated with compilation")))
240         (l/c (and err (fuel-eval--error-line/column err)))
241         (line (or (car l/c) 1))
242         (col (or (cdr l/c) 0)))
243    (find-file-other-window file)
244    (when line
245      (goto-line line)
246      (when col (forward-char col)))))
247
248(defun fuel-debug--read-restart-no ()
249  (let ((rs (fuel-debug--buffer-restarts)))
250    (unless rs (error "No restarts available"))
251    (let* ((rsn (length rs))
252           (prompt (format "Restart number? (1-%s): " rsn))
253           (no 0))
254      (while (or (> (setq no (read-number prompt)) rsn)
255                 (< no 1)))
256      no)))
257
258(defun fuel-debug-exec-restart (&optional n confirm)
259  (interactive (list (fuel-debug--read-restart-no)))
260  (let ((n (or n 1))
261        (rs (fuel-debug--buffer-restarts)))
262    (when (zerop (length rs))
263      (error "No restarts available"))
264    (when (or (< n 1) (> n (length rs)))
265      (error "Restart %s not available" n))
266    (when (or (not confirm)
267              (y-or-n-p (format "Invoke restart %s? " n)))
268      (message "Invoking restart %s" n)
269      (let* ((file (fuel-debug--buffer-file))
270             (buffer (if file (find-file-noselect file) (current-buffer))))
271        (with-current-buffer buffer
272          (fuel-debug--display-retort
273           (fuel-eval--send/wait `(:fuel ((:factor ,(format ":%s" n)))))
274           (format "Restart %s (%s) successful" n (nth (1- n) rs))))))))
275
276(defun fuel-debug-show--compiler-info (info)
277  (save-excursion
278    (goto-char (point-min))
279    (unless (re-search-forward (format "^%s" info) nil t)
280      (error "%s information not available" info))
281    (message "Retrieving %s info ..." info)
282    (unless (fuel-debug--display-retort
283             (fuel-eval--send/wait `(:fuel ((:factor ,info)))) "")
284      (error "Sorry, no %s info available" info))))
285
286(defun fuel-debug--replace-usings (file uses)
287  (pop-to-buffer (find-file-noselect file))
288  (goto-char (point-min))
289  (if (re-search-forward "^USING: " nil t)
290      (let ((begin (point))
291            (end (or (and (re-search-forward ";\\( \\|$\\)") (point))
292                     (point))))
293        (kill-region begin end))
294    (re-search-forward "^IN: " nil t)
295    (beginning-of-line)
296    (open-line 2)
297    (insert "USING: "))
298  (let ((start (point)))
299    (insert (mapconcat 'substring-no-properties uses " ") " ;")
300    (fill-region start (point) nil)))
301
302(defun fuel-debug-update-usings ()
303  (interactive)
304  (when (and fuel-debug--file fuel-debug--uses)
305    (let* ((file fuel-debug--file)
306           (old (with-current-buffer (find-file-noselect file)
307                  (fuel-syntax--find-usings t)))
308           (uses (sort (append fuel-debug--uses old) 'string<)))
309      (fuel-popup--quit)
310      (fuel-debug--replace-usings file uses))))
311
312
313;;; Fuel Debug mode:
314
315(defvar fuel-debug-mode-map
316  (let ((map (make-keymap)))
317    (suppress-keymap map)
318    (dotimes (n 9)
319      (define-key map (vector (+ ?1 n))
320        `(lambda () (interactive)
321           (fuel-debug-exec-restart ,(1+ n) fuel-debug-confirm-restarts-p))))
322    (dolist (ci fuel-debug--compiler-info-alist)
323      (define-key map (vector (cdr ci))
324        `(lambda () (interactive) (fuel-debug-show--compiler-info ,(car ci)))))
325    map))
326
327(fuel-menu--defmenu fuel-debug  fuel-debug-mode-map
328  ("Go to error" ("g" "\C-c\C-c") fuel-debug-goto-error)
329  ("Next line" "n" next-line)
330  ("Previous line" "p" previous-line)
331  ("Update USINGs" "u" fuel-debug-update-usings))
332
333(defun fuel-debug-mode ()
334  "A major mode for displaying Factor's compilation results and
335invoking restarts as needed.
336\\{fuel-debug-mode-map}"
337  (interactive)
338  (kill-all-local-variables)
339  (buffer-disable-undo)
340  (setq major-mode 'fuel-debug-mode)
341  (setq mode-name "Fuel Debug")
342  (use-local-map fuel-debug-mode-map)
343  (fuel-debug--font-lock-setup)
344  (setq fuel-debug--file nil)
345  (setq fuel-debug--last-ret nil)
346  (run-hooks 'fuel-debug-mode-hook))
347
348
349
350(provide 'fuel-debug)
351;;; fuel-debug.el ends here