/misc/fuel/fuel-debug-uses.el

http://github.com/abeaumont/factor · Emacs Lisp · 214 lines · 165 code · 35 blank · 14 comment · 3 complexity · 85ac02714536baaf0d74f4ae86cb044a MD5 · raw file

  1. ;;; fuel-debug-uses.el -- retrieving USING: stanzas
  2. ;; Copyright (C) 2008, 2009 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: Tue Dec 23, 2008 04:23
  7. ;;; Comentary:
  8. ;; Support for getting and updating factor source vocabulary lists.
  9. ;;; Code:
  10. (require 'fuel-debug)
  11. (require 'fuel-eval)
  12. (require 'fuel-popup)
  13. (require 'fuel-font-lock)
  14. (require 'fuel-base)
  15. ;;; Customization:
  16. (fuel-font-lock--defface fuel-font-lock-debug-uses-header
  17. 'bold fuel-debug "headers in Uses buffers")
  18. (fuel-font-lock--defface fuel-font-lock-debug-uses-prompt
  19. 'italic fuel-debug "prompts in Uses buffers")
  20. ;;; Utility functions:
  21. (defsubst fuel-debug--chomp (s)
  22. (replace-regexp-in-string "[\n\r\f]" "" s))
  23. (defun fuel-debug--file-lines (file)
  24. (when (file-readable-p file)
  25. (with-current-buffer (find-file-noselect file)
  26. (save-excursion
  27. (goto-char (point-min))
  28. (let ((lines) (in-usings))
  29. (while (not (eobp))
  30. (when (looking-at "^USING: ") (setq in-usings t))
  31. (let ((line (fuel-debug--chomp
  32. (substring-no-properties (thing-at-point 'line)))))
  33. (when in-usings (setq line (concat "! " line)))
  34. (push line lines))
  35. (when (and in-usings (looking-at "\\(^\\|.* \\);\\( \\|\n\\)"))
  36. (setq in-usings nil))
  37. (forward-line))
  38. (reverse lines))))))
  39. (defun fuel-debug--uses-filter (restarts)
  40. (let ((result) (i 1) (rn 0))
  41. (dolist (r restarts (reverse result))
  42. (setq rn (1+ rn))
  43. (when (string-match "Use the .+ vocabulary\\|Defer" r)
  44. (push (list i rn r) result)
  45. (setq i (1+ i))))))
  46. ;;; Retrieving USINGs:
  47. (fuel-popup--define fuel-debug--uses-buffer
  48. "*fuel uses*" 'fuel-debug-uses-mode)
  49. (make-variable-buffer-local
  50. (defvar fuel-debug--uses-file nil))
  51. (make-variable-buffer-local
  52. (defvar fuel-debug--uses-restarts nil))
  53. (defsubst fuel-debug--uses-insert-title ()
  54. (insert "Inferring USING: stanza for " fuel-debug--uses-file ".\n\n"))
  55. (defun fuel-debug--uses-prepare (file)
  56. (fuel--with-popup (fuel-debug--uses-buffer)
  57. (setq fuel-debug--uses-file file
  58. fuel-debug--uses nil
  59. fuel-debug--uses-restarts nil)
  60. (erase-buffer)
  61. (fuel-debug--uses-insert-title)))
  62. (defun fuel-debug--uses-clean ()
  63. (setq fuel-debug--uses-file nil
  64. fuel-debug--uses nil
  65. fuel-debug--uses-restarts nil))
  66. (defun fuel-debug--current-usings (file)
  67. (with-current-buffer (find-file-noselect file)
  68. (sort (fuel-syntax--find-usings t) 'string<)))
  69. (defun fuel-debug--uses-for-file (file)
  70. (let* ((lines (fuel-debug--file-lines file))
  71. (old-usings (fuel-debug--current-usings file))
  72. (cmd `(:fuel ((V{ ,@old-usings }
  73. [ V{ ,@lines } fuel-get-uses ]
  74. fuel-use-suggested-vocabs)) t t)))
  75. (fuel-debug--uses-prepare file)
  76. (fuel--with-popup (fuel-debug--uses-buffer)
  77. (insert "Asking Factor. Please, wait ...\n")
  78. (fuel-eval--send cmd 'fuel-debug--uses-cont))
  79. (fuel-popup--display (fuel-debug--uses-buffer))))
  80. (defun fuel-debug--uses-cont (retort)
  81. (let ((uses (fuel-debug--uses retort))
  82. (err (fuel-eval--retort-error retort)))
  83. (if uses (fuel-debug--uses-display uses)
  84. (fuel-debug--uses-display-err retort))))
  85. (defun fuel-debug--uses-display (uses)
  86. (let* ((inhibit-read-only t)
  87. (old (fuel-debug--current-usings fuel-debug--uses-file))
  88. (new (sort uses 'string<)))
  89. (erase-buffer)
  90. (fuel-debug--uses-insert-title)
  91. (if (equalp old new)
  92. (progn
  93. (insert "Current USING: is already fine!. Type 'q' to bury buffer.\n")
  94. (fuel-debug--uses-clean))
  95. (fuel-debug--highlight-names old new 'fuel-font-lock-debug-unneeded-vocab)
  96. (fuel-debug--highlight-names new old 'fuel-font-lock-debug-missing-vocab)
  97. (fuel-debug--insert-vlist "Current vocabulary list:" old)
  98. (newline)
  99. (fuel-debug--insert-vlist "Correct vocabulary list:" new)
  100. (setq fuel-debug--uses new)
  101. (insert "\nType 'y' to update your USING: to the new one.\n"))))
  102. (defun fuel-debug--uses-display-err (retort)
  103. (let* ((inhibit-read-only t)
  104. (err (fuel-eval--retort-error retort))
  105. (restarts (fuel-debug--uses-filter (fuel-eval--error-restarts err)))
  106. (unique (= 1 (length restarts))))
  107. (erase-buffer)
  108. (fuel-debug--uses-insert-title)
  109. (insert (fuel-eval--retort-output retort))
  110. (newline)
  111. (if (not restarts)
  112. (insert "\nSorry, couldn't infer the vocabulary list.\n")
  113. (setq fuel-debug--uses-restarts restarts)
  114. (if unique (fuel-debug--uses-restart 1)
  115. (insert "\nPlease, type the number of the desired vocabulary:\n\n")
  116. (dolist (r restarts)
  117. (insert (format " :%s %s\n" (first r) (third r))))))))
  118. (defun fuel-debug--uses-update-usings ()
  119. (interactive)
  120. (let ((inhibit-read-only t)
  121. (file fuel-debug--uses-file)
  122. (uses fuel-debug--uses))
  123. (when (and uses file)
  124. (insert "\nDone!")
  125. (fuel-debug--uses-clean)
  126. (fuel-popup--quit)
  127. (fuel-debug--replace-usings file uses)
  128. (message "USING: updated!"))))
  129. (defun fuel-debug--uses-restart (n)
  130. (when (and (> n 0) (<= n (length fuel-debug--uses-restarts)))
  131. (let* ((inhibit-read-only t)
  132. (restart (format ":%s" (cadr (nth (1- n) fuel-debug--uses-restarts))))
  133. (cmd `(:fuel ([ (:factor ,restart) ] fuel-with-autouse) t t)))
  134. (setq fuel-debug--uses-restarts nil)
  135. (insert "\nAsking Factor. Please, wait ...\n")
  136. (fuel-eval--send cmd 'fuel-debug--uses-cont))))
  137. ;;; Fuel uses mode:
  138. (defvar fuel-debug-uses-mode-map
  139. (let ((map (make-keymap)))
  140. (suppress-keymap map)
  141. (dotimes (n 9)
  142. (define-key map (vector (+ ?1 n))
  143. `(lambda () (interactive) (fuel-debug--uses-restart ,(1+ n)))))
  144. (define-key map "y" 'fuel-debug--uses-update-usings)
  145. (define-key map "\C-c\C-c" 'fuel-debug--uses-update-usings)
  146. map))
  147. (defconst fuel-debug--uses-header-regex
  148. (format "^%s.*$" (regexp-opt '("Inferring USING: stanza for "
  149. "Current USING: is already fine!"
  150. "Current vocabulary list:"
  151. "Correct vocabulary list:"
  152. "Sorry, couldn't infer the vocabulary list."
  153. "Done!"))))
  154. (defconst fuel-debug--uses-prompt-regex
  155. (format "^%s" (regexp-opt '("Asking Factor. Please, wait ..."
  156. "Please, type the number of the desired vocabulary:"
  157. "Type 'y' to update your USING: to the new one."))))
  158. (defconst fuel-debug--uses-font-lock-keywords
  159. `((,fuel-debug--uses-header-regex . 'fuel-font-lock-debug-uses-header)
  160. (,fuel-debug--uses-prompt-regex . 'fuel-font-lock-debug-uses-prompt)
  161. (,fuel-debug--restart-regex (1 'fuel-font-lock-debug-restart-number)
  162. (2 'fuel-font-lock-debug-restart-name))))
  163. (defun fuel-debug-uses-mode ()
  164. "A major mode for displaying Factor's USING: inference results."
  165. (interactive)
  166. (kill-all-local-variables)
  167. (buffer-disable-undo)
  168. (setq major-mode 'fuel-debug-uses-mode)
  169. (setq mode-name "Fuel Uses:")
  170. (set (make-local-variable 'font-lock-defaults)
  171. '(fuel-debug--uses-font-lock-keywords t nil nil nil))
  172. (use-local-map fuel-debug-uses-mode-map))
  173. (provide 'fuel-debug-uses)
  174. ;;; fuel-debug-uses.el ends here