/misc/fuel/fuel-debug.el

http://github.com/abeaumont/factor · Emacs Lisp · 351 lines · 284 code · 51 blank · 16 comment · 3 complexity · 884613b37b3a8d3ae04835d41d03391d MD5 · raw file

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