misc/fuel/fuel-debug.el

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