[MLton-commit] r5757
Vesa Karvonen
vesak at mlton.org
Wed Jul 11 04:13:59 PDT 2007
Print out a guess on why there is no info on the queried symbol.
----------------------------------------------------------------------
U mlton/trunk/ide/emacs/def-use-data.el
U mlton/trunk/ide/emacs/def-use-mode.el
U mlton/trunk/ide/emacs/esml-du-mlton.el
----------------------------------------------------------------------
Modified: mlton/trunk/ide/emacs/def-use-data.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-data.el 2007-07-11 10:15:45 UTC (rev 5756)
+++ mlton/trunk/ide/emacs/def-use-data.el 2007-07-11 11:13:58 UTC (rev 5757)
@@ -35,8 +35,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Def-use sources
-(defun def-use-add-dus (title sym-at-ref sym-to-uses finalize &rest args)
- (push (cons args (cons sym-at-ref (cons sym-to-uses (cons title finalize))))
+(defun def-use-add-dus (title sym-at-ref sym-to-uses finalize attr &rest args)
+ (push (cons args (cons sym-at-ref (cons sym-to-uses (cons attr (cons title finalize)))))
def-use-dus-list)
(def-use-show-dus-update))
@@ -52,11 +52,14 @@
(defun def-use-dus-sym-to-uses (dus sym)
(apply (caddr dus) sym (car dus)))
-(defun def-use-dus-title (dus)
+(defun def-use-dus-attr (dus)
(apply (cadddr dus) (car dus)))
+(defun def-use-dus-title (dus)
+ (apply (cadddr (cdr dus)) (car dus)))
+
(defun def-use-dus-finalize (dus)
- (apply (cddddr dus) (car dus)))
+ (apply (cddddr (cdr dus)) (car dus)))
(defvar def-use-dus-list nil)
@@ -121,6 +124,11 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Queries
+(defun def-use-attrs ()
+ (sort (mapcar (function def-use-dus-attr)
+ def-use-dus-list)
+ (function def-use-attr-newer?)))
+
(defun def-use-query (fn)
"Queries the def-use -sources with the given function and moves the
satisfied dus to the front."
@@ -138,12 +146,30 @@
(def-use-show-dus-update))
result))
-(defun def-use-sym-at-ref (ref)
- (when ref
- (def-use-query
- (function
- (lambda (dus)
- (def-use-dus-sym-at-ref dus ref))))))
+(defun def-use-sym-at-ref (ref &optional no-apology)
+ (let ((result
+ (when ref
+ (def-use-query
+ (function
+ (lambda (dus)
+ (def-use-dus-sym-at-ref dus ref)))))))
+ (unless (or result no-apology)
+ (let* ((attrs (def-use-attrs))
+ (file (def-use-ref-src ref))
+ (attr (file-attributes file))
+ (buffer (def-use-find-buffer-visiting-file file)))
+ (message
+ "Sorry, no info on the symbol. Probable reason: %s"
+ (cond
+ ((not attrs)
+ "There are no def-use sources.")
+ ((def-use-attr-newer? attr (car attrs))
+ "The file is newer than any def-use source.")
+ ((buffer-modified-p buffer)
+ "The buffer has been modified.")
+ (t
+ "The symbol may not be in any def-use source.")))))
+ result))
(defun def-use-sym-to-uses (sym)
(when sym
Modified: mlton/trunk/ide/emacs/def-use-mode.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-mode.el 2007-07-11 10:15:45 UTC (rev 5756)
+++ mlton/trunk/ide/emacs/def-use-mode.el 2007-07-11 11:13:58 UTC (rev 5757)
@@ -172,19 +172,19 @@
(end (progn (def-use-move-to-symbol-end) (point))))
(buffer-substring start end))))
-(defun def-use-sym-at-point (point)
+(defun def-use-sym-at-point (point &optional no-apology)
"Returns symbol information for the symbol at the specified point."
(let ((ref (def-use-ref-at-point point)))
(when ref
- (let ((sym (def-use-sym-at-ref ref)))
+ (let ((sym (def-use-sym-at-ref ref no-apology)))
(when (and sym
(string= (def-use-sym-name sym)
(def-use-extract-sym-name-at-point point)))
sym)))))
-(defun def-use-current-sym ()
+(defun def-use-current-sym (&optional no-apology)
"Returns symbol information for the symbol at the current point."
- (def-use-sym-at-point (point)))
+ (def-use-sym-at-point (point) no-apology))
(defun def-use-current-ref ()
"Returns a reference to the symbol at the current point."
@@ -193,8 +193,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Navigation
-(defconst def-use-apology "Sorry, no information on the symbol at point.")
-
(defvar def-use-marker-ring (make-ring def-use-marker-ring-length)
"Ring of markers which are locations from which \\[def-use-jump-to-def],
\\[def-use-jump-to-next], or \\[def-use-jump-to-prev] was invoked.")
@@ -220,8 +218,7 @@
"Jumps to the definition of the symbol under the cursor."
(interactive "P")
(let ((sym (def-use-current-sym)))
- (if (not sym)
- (message "%s" def-use-apology)
+ (when sym
(ring-insert def-use-marker-ring (point-marker))
(def-use-goto-ref (def-use-sym-ref sym) other-window))))
@@ -230,8 +227,7 @@
(interactive "P")
(let* ((ref (def-use-current-ref))
(sym (def-use-sym-at-ref ref)))
- (if (not sym)
- (message "%s" def-use-apology)
+ (when sym
(let* ((refs (def-use-all-refs-sorted sym))
(refs (if reverse (reverse refs) refs))
(refs (append refs refs)))
@@ -298,8 +294,7 @@
(interactive "P")
(let* ((ref (def-use-current-ref))
(sym (def-use-sym-at-ref ref)))
- (if (not sym)
- (message "%s" def-use-apology)
+ (when sym
(let* ((name (concat "<:" (def-use-format-sym sym) ":>"))
(buffer (get-buffer name)))
(if buffer
@@ -374,8 +369,7 @@
"Shows info on the symbol under the cursor."
(interactive)
(let ((sym (def-use-current-sym)))
- (if (not sym)
- (message "%s" def-use-apology)
+ (when sym
(message "%s" (def-use-format-sym sym)))))
(defun def-use-format-sym (sym)
@@ -472,7 +466,7 @@
"Highlights the symbol at the point."
(save-excursion
(save-window-excursion
- (def-use-highlight-sym (def-use-current-sym)))))
+ (def-use-highlight-sym (def-use-current-sym t)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Highlighting timer
Modified: mlton/trunk/ide/emacs/esml-du-mlton.el
===================================================================
--- mlton/trunk/ide/emacs/esml-du-mlton.el 2007-07-11 10:15:45 UTC (rev 5756)
+++ mlton/trunk/ide/emacs/esml-du-mlton.el 2007-07-11 11:13:58 UTC (rev 5757)
@@ -98,6 +98,7 @@
(function esml-du-sym-at-ref)
(function esml-du-sym-to-uses)
(function esml-du-finalize)
+ (function esml-du-ctx-attr)
ctx))))))
duf dont-save))))
More information about the MLton-commit
mailing list