1 ;;; fuel-debug.el -- debugging factor code
3 ;; Copyright (C) 2008, 2009, 2010 Jose Antonio Ortega Ruiz
4 ;; See http://factorcode.org/license.txt for BSD license.
6 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
7 ;; Keywords: languages, fuel, factor
8 ;; Start date: Sun Dec 07, 2008 04:16
12 ;; A mode for displaying the results of run-file and evaluation, with
13 ;; support for restarts.
26 (defgroup fuel-debug nil
27 "Major mode for interaction with the Factor debugger."
30 (defcustom fuel-debug-mode-hook nil
31 "Hook run after `fuel-debug-mode' activates."
35 (defcustom fuel-debug-confirm-restarts-p t
36 "Whether to ask for confimation before executing a restart in
41 (defcustom fuel-debug-show-short-help t
42 "Whether to show short help on available keys in debugger."
46 (defface fuel-font-lock-debug-error '((t (:inherit font-lock-warning-face)))
50 (defface fuel-font-lock-debug-line
51 '((t (:inherit font-lock-variable-name-face)))
52 "line numbers in errors/warnings"
55 (defface fuel-font-lock-debug-column
56 '((t (:inherit font-lock-variable-name-face)))
57 "column numbers in errors/warnings"
60 (defface fuel-font-lock-debug-info '((t (:inherit font-lock-comment-face)))
64 (defface fuel-font-lock-debug-restart-number
65 '((t (:inherit font-lock-warning-face)))
69 (defface fuel-font-lock-debug-restart-name
70 '((t (:inherit font-lock-function-name-face)))
74 (defface fuel-font-lock-debug-missing-vocab
75 '((t (:inherit font-lock-warning-face)))
76 "missing vocabulary names"
79 (defface fuel-font-lock-debug-unneeded-vocab
80 '((t (:inherit font-lock-warning-face)))
81 "unneeded vocabulary names"
85 ;;; Font lock and other pattern matching:
87 (defconst fuel-debug--compiler-info-alist
88 '((":warnings" . ?w) (":errors" . ?e) (":linkage" . ?l)))
90 (defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"")
91 (defconst fuel-debug--error-line-regex "\\([0-9]+\\):")
92 (defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$")
94 (defconst fuel-debug--error-regex
96 fuel-debug--error-file-regex
97 fuel-debug--error-line-regex))
99 (defconst fuel-debug--compiler-info-regex
101 (regexp-opt (mapcar 'car fuel-debug--compiler-info-alist))))
103 (defconst fuel-debug--restart-regex "^:\\([0-9]+\\) \\(.+\\)")
105 (defconst fuel-debug--font-lock-keywords
106 `((,fuel-debug--error-file-regex . 'fuel-font-lock-debug-error)
107 (,fuel-debug--error-line-regex 1 'fuel-font-lock-debug-line)
108 (,fuel-debug--error-cont-regex 1 'fuel-font-lock-debug-column)
109 (,fuel-debug--restart-regex (1 'fuel-font-lock-debug-restart-number)
110 (2 'fuel-font-lock-debug-restart-name))
111 (,fuel-debug--compiler-info-regex 1 'fuel-font-lock-debug-restart-number)
112 ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-font-lock-debug-info)
113 ("^Error: " . 'fuel-font-lock-debug-error)))
118 (defun fuel-debug--buffer ()
119 (or (get-buffer "*fuel debug*")
120 (with-current-buffer (get-buffer-create "*fuel debug*")
125 (defvar-local fuel-debug--last-ret nil)
127 (defvar-local fuel-debug--file nil)
129 (defvar-local fuel-debug--uses nil)
131 (defun fuel-debug--prepare-compilation (file msg)
132 (let ((inhibit-read-only t))
133 (with-current-buffer (fuel-debug--buffer)
136 (setq fuel-debug--file file))))
138 (defun fuel-debug--display-retort (ret &optional success-msg no-pop)
139 (let ((err (fuel-eval--retort-error ret))
140 (inhibit-read-only t))
141 (with-current-buffer (fuel-debug--buffer)
143 (fuel-debug--display-output ret)
147 ((and (not err) success-msg)
148 (message "%s" success-msg)
149 (insert "\n" success-msg "\n"))
150 ((eq (car err) 'fuel-con-error)
151 (fuel-debug--display-parse-error (second err)))
153 (fuel-debug--display-restarts err)
156 (fuel-debug--display-uses ret)
157 (let ((hstr (fuel-debug--help-string err fuel-debug--file)))
158 (if fuel-debug-show-short-help
159 (insert "-----------\n" hstr "\n")
160 (message "%s" hstr)))
161 (setq fuel-debug--last-ret ret)
162 (goto-char (point-max))
163 (font-lock-fontify-buffer)
164 (when (and err (not no-pop)) (fuel-popup--display))
167 (defun fuel-debug--uses (ret)
168 (let ((uses (fuel-eval--retort-result ret)))
169 (and (eq :uses (car uses))
172 (defun fuel-debug--insert-vlist (title vlist)
173 (goto-char (point-max))
174 (insert title "\n\n ")
175 (let ((i 0) (step 5))
179 (insert (if (zerop (mod i step)) "\n " " ")))
180 (unless (zerop (mod i step)) (newline))
183 (defun fuel-debug--highlight-names (names ref face)
185 (when (not (member n ref))
186 (put-text-property 0 (length n) 'font-lock-face face n))))
188 (defun fuel-debug--display-uses (ret)
189 (when (setq fuel-debug--uses (fuel-debug--uses ret))
191 (fuel-debug--highlight-names fuel-debug--uses
192 nil 'fuel-font-lock-debug-missing-vocab)
193 (fuel-debug--insert-vlist "Missing vocabularies:" fuel-debug--uses)
196 (defun fuel-debug--display-output (ret)
197 "Diplays the retort `ret' in fuels debug buffer."
198 (let* ((last (fuel-eval--retort-output fuel-debug--last-ret))
199 (current (fuel-eval--retort-output ret))
201 (clen (length current))
202 (trail (and last (substring-no-properties last (/ llen 2))))
203 (err (fuel-eval--retort-error ret))
205 (when current (save-excursion (insert current)))
206 (when (and (> clen llen) (> llen 0) (search-forward trail nil t))
207 (delete-region p (point)))
208 (goto-char (point-max))
210 (insert (format "\nError: %S\n\n" (fuel-eval--error-name err))))))
212 (defun fuel-debug--display-parse-error (str)
215 "FUEL failed to parse the connection response, displayed below:\n\n%s\n\n" str)))
217 (defun fuel-debug--display-restarts (err)
218 (let* ((rs (fuel-eval--error-restarts err))
221 (insert "Restarts:\n\n")
223 (insert (format ":%s %s\n" (1+ n) (nth n rs))))
226 (defun fuel-debug--help-string (err &optional file)
227 (format "Press %s%s%s%sq bury buffer"
228 (if (or file (fuel-eval--error-file err)) "g go to file, " "")
229 (let ((rsn (length (fuel-eval--error-restarts err))))
230 (cond ((zerop rsn) "")
231 ((= 1 rsn) "1 invoke restart, ")
232 (t (format "1-%s invoke restarts, " rsn))))
234 (dolist (ci fuel-debug--compiler-info-alist str)
236 (goto-char (point-min))
237 (when (search-forward (car ci) nil t)
238 (setq str (format "%c %s, %s" (cdr ci) (car ci) str))))))
239 (if fuel-debug--uses "u to update USING:, " "")))
241 (defun fuel-debug--buffer-file ()
242 (with-current-buffer (fuel-debug--buffer)
244 (and fuel-debug--last-ret
245 (fuel-eval--error-file
246 (fuel-eval--retort-error fuel-debug--last-ret))))))
248 (defsubst fuel-debug--buffer-error ()
249 (fuel-eval--retort-error fuel-debug--last-ret))
251 (defsubst fuel-debug--buffer-restarts ()
252 (fuel-eval--error-restarts (fuel-debug--buffer-error)))
255 ;;; Buffer navigation:
257 (defun fuel-debug-goto-error ()
259 (let* ((err (fuel-debug--buffer-error))
260 (file (or (fuel-debug--buffer-file)
261 (error "No file associated with compilation")))
262 (l/c (and err (fuel-eval--error-line/column err)))
263 (line (or (car l/c) 1))
264 (col (or (cdr l/c) 0)))
265 (find-file-other-window file)
267 (goto-char (point-min))
268 (forward-line (1- line))
269 (when col (forward-char col)))))
271 (defun fuel-debug--read-restart-no ()
272 (let ((rs (fuel-debug--buffer-restarts)))
273 (unless rs (error "No restarts available"))
274 (let* ((rsn (length rs))
275 (prompt (format "Restart number? (1-%s): " rsn))
277 (while (or (> (setq no (read-number prompt)) rsn)
281 (defun fuel-debug-exec-restart (&optional n confirm)
282 (interactive (list (fuel-debug--read-restart-no)))
284 (rs (fuel-debug--buffer-restarts)))
285 (when (zerop (length rs))
286 (error "No restarts available"))
287 (when (or (< n 1) (> n (length rs)))
288 (error "Restart %s not available" n))
289 (when (or (not confirm)
290 (y-or-n-p (format "Invoke restart %s? " n)))
291 (message "Invoking restart %s" n)
292 (let* ((file (fuel-debug--buffer-file))
293 (buffer (if file (find-file-noselect file) (current-buffer))))
294 (with-current-buffer buffer
295 (fuel-debug--display-retort
296 (fuel-eval--send/wait `(:fuel ((:factor ,(format ":%s" n)))))
297 (format "Restart %s (%s) successful" n (nth (1- n) rs))))))))
299 (defun fuel-debug-show--compiler-info (info)
301 (goto-char (point-min))
302 (unless (re-search-forward (format "^%s" info) nil t)
303 (error "%s information not available" info))
304 (message "Retrieving %s info ..." info)
305 (unless (fuel-debug--display-retort
306 (fuel-eval--send/wait `(:fuel ((:factor ,info)))) "")
307 (error "Sorry, no %s info available" info))))
309 (defun fuel-debug--replace-usings (file uses)
310 (pop-to-buffer (find-file-noselect file))
312 (goto-char (point-min))
313 (if (re-search-forward "^USING: " nil t)
314 (let ((begin (point))
315 (end (or (and (re-search-forward ";\\( \\|$\\)") (point))
317 (kill-region begin end))
318 (re-search-forward "^IN: " nil t)
322 (let ((start (point))
323 (tokens (append uses '(";"))))
324 (insert (mapconcat 'substring-no-properties tokens " "))
325 (fill-region start (point) nil))))
327 (defun fuel-debug-update-usings ()
329 (when (and fuel-debug--file fuel-debug--uses)
330 (let* ((file fuel-debug--file)
331 (old (with-current-buffer (find-file-noselect file)
332 (factor-find-usings t)))
333 (uses (sort (append fuel-debug--uses old) 'string<)))
335 (fuel-debug--replace-usings file uses))))
341 (define-derived-mode fuel-debug-mode fundamental-mode "FUEL Debug"
342 "A major mode for displaying Factor's compilation results and
343 invoking restarts as needed.
344 \\{fuel-debug-mode-map}"
345 (buffer-disable-undo)
347 (suppress-keymap fuel-debug-mode-map)
349 (define-key fuel-debug-mode-map (vector (+ ?1 n))
350 `(lambda () (interactive)
351 (fuel-debug-exec-restart ,(1+ n) fuel-debug-confirm-restarts-p))))
352 (dolist (ci fuel-debug--compiler-info-alist)
353 (define-key fuel-debug-mode-map (vector (cdr ci))
354 `(lambda () (interactive) (fuel-debug-show--compiler-info ,(car ci)))))
356 (setq font-lock-defaults
357 '(fuel-debug--font-lock-keywords t nil nil nil)))
359 (fuel-menu--defmenu fuel-debug fuel-debug-mode-map
360 ("Go to error" ("g" "\C-c\C-c") fuel-debug-goto-error)
361 ("Next line" "n" next-line)
362 ("Previous line" "p" previous-line)
363 ("Update USINGs" "u" fuel-debug-update-usings))
366 (provide 'fuel-debug)
368 ;;; fuel-debug.el ends here