1 ;; Copyright (C) 2007 Vesa Karvonen
3 ;; MLton is released under a BSD-style license.
4 ;; See the file MLton-LICENSE for details.
8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (defalias 'def-use-pos
(function cons
))
12 (defalias 'def-use-pos-line
(function car
))
13 (defalias 'def-use-pos-col
(function cdr
))
14 (defun def-use-pos< (lhs rhs
)
15 (or (< (def-use-pos-line lhs
) (def-use-pos-line rhs
))
16 (and (equal (def-use-pos-line lhs
) (def-use-pos-line rhs
))
17 (< (def-use-pos-col lhs
) (def-use-pos-col rhs
)))))
19 (defalias 'def-use-ref
(function cons
))
20 (defalias 'def-use-ref-src
(function car
))
21 (defalias 'def-use-ref-pos
(function cdr
))
22 (defun def-use-ref< (lhs rhs
)
23 (or (string< (def-use-ref-src lhs
) (def-use-ref-src rhs
))
24 (and (equal (def-use-ref-src lhs
) (def-use-ref-src rhs
))
25 (def-use-pos< (def-use-ref-pos lhs
) (def-use-ref-pos rhs
)))))
27 (defun def-use-sym (class msg name ref
&optional face
)
29 (cons ref
(cons name
(cons class
(cons msg face
)))))
30 (defalias 'def-use-sym-face
(function cddddr
))
31 (defalias 'def-use-sym-msg
(function cadddr
))
32 (defalias 'def-use-sym-class
(function caddr
))
33 (defalias 'def-use-sym-name
(function cadr
))
34 (defalias 'def-use-sym-ref
(function car
))
36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39 (defun def-use-add-dus (title sym-at-ref sym-to-uses finalize attr
&rest args
)
40 (push `(,args
,sym-at-ref
,sym-to-uses
,attr
,title .
,finalize
)
42 (def-use-show-dus-update))
44 (defun def-use-rem-dus (dus)
45 (setq def-use-dus-list
46 (remove dus def-use-dus-list
))
47 (def-use-dus-finalize dus
)
48 (def-use-show-dus-update))
50 (defun def-use-dus-sym-at-ref (dus ref
)
51 (apply (cadr dus
) ref
(car dus
)))
53 (defun def-use-dus-sym-to-uses (dus sym
)
54 (apply (caddr dus
) sym
(car dus
)))
56 (defun def-use-dus-attr (dus)
57 (apply (cadddr dus
) (car dus
)))
59 (defun def-use-dus-title (dus)
60 (apply (cadddr (cdr dus
)) (car dus
)))
62 (defun def-use-dus-finalize (dus)
63 (apply (cddddr (cdr dus
)) (car dus
)))
65 (defvar def-use-dus-list nil
)
67 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
68 ;; Def-Use Sources -mode
70 (defconst def-use-show-dus-buffer-name
"<:Def-Use Sources:>")
72 (defconst def-use-show-dus-mode-map
73 (let ((result (make-sparse-keymap)))
77 (read (car key-command
))
80 .
,(function def-use-kill-current-buffer
))
82 .
,(function def-use-show-dus-del
))))
85 (define-derived-mode def-use-show-dus-mode fundamental-mode
"Def-Use-DUS"
86 "Major mode for browsing def-use sources."
89 (defun def-use-show-dus ()
90 "Show a list of def-use sources."
92 (let ((buffer (get-buffer-create def-use-show-dus-buffer-name
)))
93 (with-current-buffer buffer
95 (setq buffer-read-only t
)
96 (def-use-show-dus-mode))
97 (switch-to-buffer buffer
))
98 (def-use-show-dus-update))
100 (defun def-use-show-dus-update ()
101 (let ((buffer (get-buffer def-use-show-dus-buffer-name
)))
103 (with-current-buffer buffer
104 (let ((point (point)))
105 (setq buffer-read-only nil
)
107 (delete-char (buffer-size))
108 (insert "Def-Use Sources\n"
112 (insert (def-use-dus-title dus
) "\n")))
114 (setq buffer-read-only t
)
115 (goto-char point
))))))
117 (defun def-use-show-dus-del ()
118 "Kill the def-use source on the current line."
120 (let ((idx (- (def-use-current-line) 3)))
121 (when (and (<= 0 idx
)
122 (< idx
(length def-use-dus-list
)))
123 (def-use-rem-dus (nth idx def-use-dus-list
)))))
125 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
128 (defun def-use-attrs ()
129 (sort (mapcar (function def-use-dus-attr
)
131 (function def-use-attr-newer?
)))
133 (defun def-use-query (fn)
134 "Queries the def-use -sources with the given function and moves the
135 satisfied dus to the front."
137 (work def-use-dus-list
)
140 (not (setq result
(funcall fn
(car work
)))))
142 (setq work
(cdr work
)))
143 (when (and prev work
)
144 (setcdr prev
(cdr work
))
145 (setcdr work def-use-dus-list
)
146 (setq def-use-dus-list work
)
147 (def-use-show-dus-update))
150 (defun def-use-sym-at-ref (ref &optional no-apology
)
156 (def-use-dus-sym-at-ref dus ref
)))))
157 (name (def-use-extract-sym-name-at-ref ref
)))
158 (if (and sym name
(string= (def-use-sym-name sym
) name
))
163 (message "Point does not appear to be on a symbol."))
164 ((and sym
(not (string= (def-use-sym-name sym
) name
)))
166 "Symbol at point, %s, does not match, %s, in info. Check mode."
168 (def-use-sym-name sym
)))
170 (let* ((attrs (def-use-attrs))
171 (file (def-use-ref-src ref
))
172 (attr (file-attributes file
))
173 (buffer (def-use-find-buffer-visiting-file file
)))
175 "Sorry, no valid info on the symbol: %s. Possible reason: %s."
179 "There are no def-use sources")
180 ((def-use-attr-newer? attr
(car attrs
))
181 "The file is newer than any def-use source")
182 ((buffer-modified-p buffer
)
183 "The buffer has been modified")
185 "The symbol may not be in any def-use source")))))))
188 (defun def-use-sym-to-uses (sym)
193 (def-use-dus-sym-to-uses dus sym
))))))
195 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
197 (provide 'def-use-data
)