misc/fuel/fuel-debug-uses.el

   1 ;;; fuel-debug-uses.el -- retrieving USING: stanzas
   2
   3 ;; Copyright (C) 2008 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: Tue Dec 23, 2008 04:23
   9
  10 ;;; Comentary:
  11
  12 ;; Support for getting and updating factor source vocabulary lists.
  13
  14 ;;; Code:
  15
  16 (require 'fuel-debug)
  17 (require 'fuel-eval)
  18 (require 'fuel-popup)
  19 (require 'fuel-font-lock)
  20 (require 'fuel-base)
  21
  22
  23 \f
  24 ;;; Customization:
  25
  26 (fuel-font-lock--defface fuel-font-lock-debug-missing-vocab
  27   'font-lock-warning-face fuel-debug "missing vocabulary names")
  28
  29 (fuel-font-lock--defface fuel-font-lock-debug-unneeded-vocab
  30   'font-lock-warning-face fuel-debug "unneeded vocabulary names")
  31
  32 (fuel-font-lock--defface fuel-font-lock-debug-uses-header
  33   'bold fuel-debug "headers in Uses buffers")
  34
  35 (fuel-font-lock--defface fuel-font-lock-debug-uses-prompt
  36   'italic fuel-debug "prompts in Uses buffers")
  37
  38 \f
  39 ;;; Utility functions:
  40
  41 (defun fuel-debug--file-lines (file)
  42   (when (file-readable-p file)
  43     (with-current-buffer (find-file-noselect file)
  44       (save-excursion
  45         (goto-char (point-min))
  46         (let ((lines) (in-usings))
  47           (while (not (eobp))
  48             (when (looking-at "^USING: ") (setq in-usings t))
  49             (let ((line (substring-no-properties (thing-at-point 'line) 0 -1)))
  50               (when in-usings (setq line (concat "! " line)))
  51               (push line lines))
  52             (when (and in-usings (looking-at ".*\\_<;\\_>")) (setq in-usings nil))
  53             (forward-line))
  54           (reverse lines))))))
  55
  56 (defun fuel-debug--highlight-names (names ref face)
  57   (dolist (n names)
  58     (when (not (member n ref))
  59       (put-text-property 0 (length n) 'font-lock-face face n))))
  60
  61 (defun fuel-debug--uses-new-uses (file uses)
  62   (pop-to-buffer (find-file-noselect file))
  63   (goto-char (point-min))
  64   (if (re-search-forward "^USING: " nil t)
  65       (let ((begin (point))
  66             (end (or (and (re-search-forward "\\_<;\\_>") (point)) (point))))
  67         (kill-region begin end))
  68     (re-search-forward "^IN: " nil t)
  69     (beginning-of-line)
  70     (open-line 2)
  71     (insert "USING: "))
  72   (let ((start (point)))
  73     (insert (mapconcat 'substring-no-properties uses " ") " ;")
  74     (fill-region start (point) nil)))
  75
  76 (defun fuel-debug--uses-filter (restarts)
  77   (let ((result) (i 1) (rn 0))
  78     (dolist (r restarts (reverse result))
  79       (setq rn (1+ rn))
  80       (when (string-match "Use the .+ vocabulary\\|Defer" r)
  81         (push (list i rn r) result)
  82         (setq i (1+ i))))))
  83
  84 \f
  85 ;;; Retrieving USINGs:
  86
  87 (fuel-popup--define fuel-debug--uses-buffer
  88   "*fuel uses*" 'fuel-debug-uses-mode)
  89
  90 (make-variable-buffer-local
  91  (defvar fuel-debug--uses nil))
  92
  93 (make-variable-buffer-local
  94  (defvar fuel-debug--uses-file nil))
  95
  96 (make-variable-buffer-local
  97  (defvar fuel-debug--uses-restarts nil))
  98
  99 (defsubst fuel-debug--uses-insert-title ()
 100   (insert "Infering USING: stanza for " fuel-debug--uses-file ".\n\n"))
 101
 102 (defun fuel-debug--uses-prepare (file)
 103   (fuel--with-popup (fuel-debug--uses-buffer)
 104     (setq fuel-debug--uses-file file
 105           fuel-debug--uses nil
 106           fuel-debug--uses-restarts nil)
 107     (erase-buffer)
 108     (fuel-debug--uses-insert-title)))
 109
 110 (defun fuel-debug--uses-clean ()
 111   (setq fuel-debug--uses-file nil
 112         fuel-debug--uses nil
 113         fuel-debug--uses-restarts nil))
 114
 115 (defun fuel-debug--uses-for-file (file)
 116   (let* ((lines (fuel-debug--file-lines file))
 117          (cmd `(:fuel ((V{ ,@lines } fuel-get-uses)) t t)))
 118     (fuel-debug--uses-prepare file)
 119     (fuel--with-popup (fuel-debug--uses-buffer)
 120       (insert "Asking Factor. Please, wait ...\n")
 121       (fuel-eval--send cmd 'fuel-debug--uses-cont))
 122     (fuel-popup--display (fuel-debug--uses-buffer))))
 123
 124 (defun fuel-debug--uses-cont (retort)
 125   (let ((uses (fuel-eval--retort-result retort))
 126         (err (fuel-eval--retort-error retort)))
 127     (if uses (fuel-debug--uses-display uses)
 128       (fuel-debug--uses-display-err retort))))
 129
 130 (defun fuel-debug--insert-vlist (title vlist)
 131   (goto-char (point-max))
 132   (insert title "\n\n  ")
 133   (let ((i 0) (step 5))
 134     (dolist (v vlist)
 135       (setq i (1+ i))
 136       (insert v)
 137       (insert (if (zerop (mod i step)) "\n  " " ")))
 138     (unless (zerop (mod i step)) (newline))
 139     (newline)))
 140
 141 (defun fuel-debug--uses-display (uses)
 142   (let* ((inhibit-read-only t)
 143          (old (with-current-buffer (find-file-noselect fuel-debug--uses-file)
 144                 (fuel-syntax--usings)))
 145          (old (sort old 'string<))
 146          (new (sort uses 'string<)))
 147     (erase-buffer)
 148     (fuel-debug--uses-insert-title)
 149     (if (equalp old new)
 150         (progn
 151           (insert "Current USING: is already fine!. Type 'q' to bury buffer.\n")
 152           (fuel-debug--uses-clean))
 153       (fuel-debug--highlight-names old new 'fuel-font-lock-debug-unneeded-vocab)
 154       (fuel-debug--highlight-names new old 'fuel-font-lock-debug-missing-vocab)
 155       (fuel-debug--insert-vlist "Current vocabulary list:" old)
 156       (newline)
 157       (fuel-debug--insert-vlist "Correct vocabulary list:" new)
 158       (setq fuel-debug--uses new)
 159       (insert "\nType 'y' to update your USING: to the new one.\n"))))
 160
 161 (defun fuel-debug--uses-display-err (retort)
 162   (let* ((inhibit-read-only t)
 163          (err (fuel-eval--retort-error retort))
 164          (restarts (fuel-debug--uses-filter (fuel-eval--error-restarts err)))
 165          (unique (= 1 (length restarts))))
 166     (erase-buffer)
 167     (fuel-debug--uses-insert-title)
 168     (insert (fuel-eval--retort-output retort))
 169     (newline)
 170     (if (not restarts)
 171         (insert "\nSorry, couldn't infer the vocabulary list.\n")
 172       (setq fuel-debug--uses-restarts restarts)
 173       (if unique (fuel-debug--uses-restart 1)
 174         (insert "\nPlease, type the number of the desired vocabulary:\n\n")
 175         (dolist (r restarts)
 176           (insert (format " :%s %s\n" (first r) (third r))))))))
 177
 178 (defun fuel-debug--uses-update-usings ()
 179   (interactive)
 180   (let ((inhibit-read-only t))
 181     (when (and fuel-debug--uses-file fuel-debug--uses)
 182       (fuel-debug--uses-new-uses fuel-debug--uses-file fuel-debug--uses)
 183       (message "USING: updated!")
 184       (with-current-buffer (fuel-debug--uses-buffer)
 185         (insert "\nDone!")
 186         (fuel-debug--uses-clean)
 187         (bury-buffer)))))
 188
 189 (defun fuel-debug--uses-restart (n)
 190   (when (and (> n 0) (<= n (length fuel-debug--uses-restarts)))
 191     (let* ((inhibit-read-only t)
 192            (restart (format ":%s" (cadr (nth (1- n) fuel-debug--uses-restarts))))
 193            (cmd `(:fuel ([ (:factor ,restart) ] fuel-with-autouse) t t)))
 194       (setq fuel-debug--uses-restarts nil)
 195       (insert "\nAsking Factor. Please, wait ...\n")
 196       (fuel-eval--send cmd 'fuel-debug--uses-cont))))
 197
 198 \f
 199 ;;; Fuel uses mode:
 200
 201 (defvar fuel-debug-uses-mode-map
 202   (let ((map (make-keymap)))
 203     (suppress-keymap map)
 204     (dotimes (n 9)
 205       (define-key map (vector (+ ?1 n))
 206         `(lambda () (interactive) (fuel-debug--uses-restart ,(1+ n)))))
 207     (define-key map "y" 'fuel-debug--uses-update-usings)
 208     (define-key map "\C-c\C-c" 'fuel-debug--uses-update-usings)
 209     map))
 210
 211 (defconst fuel-debug--uses-header-regex
 212   (format "^%s.*$" (regexp-opt '("Infering USING: stanza for "
 213                               "Current USING: is already fine!"
 214                               "Current vocabulary list:"
 215                               "Correct vocabulary list:"
 216                               "Sorry, couldn't infer the vocabulary list."
 217                               "Done!"))))
 218
 219 (defconst fuel-debug--uses-prompt-regex
 220   (format "^%s" (regexp-opt '("Asking Factor. Please, wait ..."
 221                               "Please, type the number of the desired vocabulary:"
 222                               "Type 'y' to update your USING: to the new one."))))
 223
 224 (defconst fuel-debug--uses-font-lock-keywords
 225   `((,fuel-debug--uses-header-regex . 'fuel-font-lock-debug-uses-header)
 226     (,fuel-debug--uses-prompt-regex . 'fuel-font-lock-debug-uses-prompt)
 227     (,fuel-debug--restart-regex (1 'fuel-font-lock-debug-restart-number)
 228                                 (2 'fuel-font-lock-debug-restart-name))))
 229
 230 (defun fuel-debug-uses-mode ()
 231   "A major mode for displaying Factor's USING: inference results."
 232   (interactive)
 233   (kill-all-local-variables)
 234   (buffer-disable-undo)
 235   (setq major-mode 'fuel-debug-uses-mode)
 236   (setq mode-name "Fuel Uses:")
 237   (set (make-local-variable 'font-lock-defaults)
 238        '(fuel-debug--uses-font-lock-keywords t nil nil nil))
 239   (use-local-map fuel-debug-uses-mode-map))
 240
 241 \f
 242 (provide 'fuel-debug-uses)
 243 ;;; fuel-debug-uses.el ends here