misc/fuel/fuel-debug.el

   1 ;;; fuel-debug.el -- debugging factor code -*- lexical-binding: t -*-
   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-menu)
  20 (require 'fuel-base)
  21
  22 \f
  23 ;;; Customization:
  24
  25 ;;;###autoload
  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
  37 the 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 (defface fuel-font-lock-debug-error '((t (:inherit font-lock-warning-face)))
  47   "highlighting errors"
  48   :group 'fuel-debug)
  49
  50 (defface fuel-font-lock-debug-line
  51   '((t (:inherit font-lock-variable-name-face)))
  52   "line numbers in errors/warnings"
  53   :group 'fuel-debug)
  54
  55 (defface fuel-font-lock-debug-column
  56   '((t (:inherit font-lock-variable-name-face)))
  57   "column numbers in errors/warnings"
  58   :group 'fuel-debug)
  59
  60 (defface fuel-font-lock-debug-info '((t (:inherit font-lock-comment-face)))
  61   "information headers"
  62   :group 'fuel-debug)
  63
  64 (defface fuel-font-lock-debug-restart-number
  65   '((t (:inherit font-lock-warning-face)))
  66   "restart numbers"
  67   :group 'fuel-debug)
  68
  69 (defface fuel-font-lock-debug-restart-name
  70   '((t (:inherit font-lock-function-name-face)))
  71   "restart names"
  72   :group 'fuel-debug)
  73
  74 (defface fuel-font-lock-debug-missing-vocab
  75   '((t (:inherit font-lock-warning-face)))
  76   "missing vocabulary names"
  77   :group 'fuel-debug)
  78
  79 (defface fuel-font-lock-debug-unneeded-vocab
  80   '((t (:inherit font-lock-warning-face)))
  81   "unneeded vocabulary names"
  82   :group 'fuel-debug)
  83
  84 \f
  85 ;;; Font lock and other pattern matching:
  86
  87 (defconst fuel-debug--compiler-info-alist
  88   '((":warnings" . ?w) (":errors" . ?e) (":linkage" . ?l)))
  89
  90 (defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"")
  91 (defconst fuel-debug--error-line-regex "\\([0-9]+\\):")
  92 (defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$")
  93
  94 (defconst fuel-debug--error-regex
  95   (format "%s\n%s"
  96           fuel-debug--error-file-regex
  97           fuel-debug--error-line-regex))
  98
  99 (defconst fuel-debug--compiler-info-regex
 100   (format "^\\(%s\\) "
 101           (regexp-opt (mapcar 'car fuel-debug--compiler-info-alist))))
 102
 103 (defconst fuel-debug--restart-regex "^:\\([0-9]+\\) \\(.+\\)")
 104
 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)))
 114
 115 \f
 116 ;;; Debug buffer:
 117
 118 (defun fuel-debug--buffer ()
 119   (or (get-buffer "*fuel debug*")
 120       (with-current-buffer (get-buffer-create "*fuel debug*")
 121         (fuel-debug-mode)
 122         (fuel-popup-mode)
 123         (current-buffer))))
 124
 125 (defvar-local fuel-debug--last-ret nil)
 126
 127 (defvar-local fuel-debug--file nil)
 128
 129 (defvar-local fuel-debug--uses nil)
 130
 131 (defun fuel-debug--prepare-compilation (file msg)
 132   (let ((inhibit-read-only t))
 133     (with-current-buffer (fuel-debug--buffer)
 134       (erase-buffer)
 135       (insert msg)
 136       (setq fuel-debug--file file))))
 137
 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)
 142       (erase-buffer)
 143       (fuel-debug--display-output ret)
 144       (delete-blank-lines)
 145       (newline)
 146       (cond
 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)))
 152        (err
 153         (fuel-debug--display-restarts err)
 154         (delete-blank-lines)
 155         (newline)))
 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))
 165       (not err))))
 166
 167 (defun fuel-debug--uses (ret)
 168   (let ((uses (fuel-eval--retort-result ret)))
 169     (and (eq :uses (car uses))
 170          (cdr uses))))
 171
 172 (defun fuel-debug--insert-vlist (title vlist)
 173   (goto-char (point-max))
 174   (insert title "\n\n  ")
 175   (let ((i 0) (step 5))
 176     (dolist (v vlist)
 177       (setq i (1+ i))
 178       (insert v)
 179       (insert (if (zerop (mod i step)) "\n  " " ")))
 180     (unless (zerop (mod i step)) (newline))
 181     (newline)))
 182
 183 (defun fuel-debug--highlight-names (names ref face)
 184   (dolist (n names)
 185     (when (not (member n ref))
 186       (put-text-property 0 (length n) 'font-lock-face face n))))
 187
 188 (defun fuel-debug--display-uses (ret)
 189   (when (setq fuel-debug--uses (fuel-debug--uses ret))
 190     (newline)
 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)
 194     (newline)))
 195
 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))
 200          (llen (length last))
 201          (clen (length current))
 202          (trail (and last (substring-no-properties last (/ llen 2))))
 203          (err (fuel-eval--retort-error ret))
 204          (p (point)))
 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))
 209     (when err
 210       (insert (format "\nError: %S\n\n" (fuel-eval--error-name err))))))
 211
 212 (defun fuel-debug--display-parse-error (str)
 213   (insert
 214    (format
 215     "FUEL failed to parse the connection response, displayed below:\n\n%s\n\n" str)))
 216
 217 (defun fuel-debug--display-restarts (err)
 218   (let* ((rs (fuel-eval--error-restarts err))
 219          (rsn (length rs)))
 220     (when rs
 221       (insert "Restarts:\n\n")
 222       (dotimes (n rsn)
 223         (insert (format ":%s %s\n" (1+ n) (nth n rs))))
 224       (newline))))
 225
 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))))
 233           (let ((str ""))
 234             (dolist (ci fuel-debug--compiler-info-alist str)
 235               (save-excursion
 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:, " "")))
 240
 241 (defun fuel-debug--buffer-file ()
 242   (with-current-buffer (fuel-debug--buffer)
 243     (or fuel-debug--file
 244         (and fuel-debug--last-ret
 245              (fuel-eval--error-file
 246               (fuel-eval--retort-error fuel-debug--last-ret))))))
 247
 248 (defsubst fuel-debug--buffer-error ()
 249   (fuel-eval--retort-error fuel-debug--last-ret))
 250
 251 (defsubst fuel-debug--buffer-restarts ()
 252   (fuel-eval--error-restarts (fuel-debug--buffer-error)))
 253
 254 \f
 255 ;;; Buffer navigation:
 256
 257 (defun fuel-debug-goto-error ()
 258   (interactive)
 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)
 266     (when line
 267       (goto-char (point-min))
 268       (forward-line (1- line))
 269       (when col (forward-char col)))))
 270
 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))
 276            (no 0))
 277       (while (or (> (setq no (read-number prompt)) rsn)
 278                  (< no 1)))
 279       no)))
 280
 281 (defun fuel-debug-exec-restart (&optional n confirm)
 282   (interactive (list (fuel-debug--read-restart-no)))
 283   (let ((n (or n 1))
 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))))))))
 298
 299 (defun fuel-debug-show--compiler-info (info)
 300   (save-excursion
 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))))
 308
 309 (defun fuel-debug--replace-usings (file uses)
 310   (pop-to-buffer (find-file-noselect file))
 311   (save-excursion
 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))
 316                        (point))))
 317           (kill-region begin end))
 318       (re-search-forward "^IN: " nil t)
 319       (beginning-of-line)
 320       (open-line 2)
 321       (insert "USING: "))
 322     (let ((start (point))
 323           (tokens (append uses '(";"))))
 324       (insert (mapconcat 'substring-no-properties tokens " "))
 325       (fill-region start (point) nil))))
 326
 327 (defun fuel-debug-update-usings ()
 328   (interactive)
 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<)))
 334       (fuel-popup--quit)
 335       (fuel-debug--replace-usings file uses))))
 336
 337 \f
 338 ;;; Fuel Debug mode:
 339
 340 ;;;###autoload
 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)
 346
 347   (suppress-keymap fuel-debug-mode-map)
 348   (dotimes (n 9)
 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)))))
 355
 356   (setq font-lock-defaults
 357         '(fuel-debug--font-lock-keywords t nil nil nil)))
 358
 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))
 364
 365 \f
 366 (provide 'fuel-debug)
 367
 368 ;;; fuel-debug.el ends here