misc/fuel/fuel-debug-uses.el

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