ide/emacs/def-use-mode.el

   1 ;; Copyright (C) 2007 Vesa Karvonen
   2 ;;
   3 ;; MLton is released under a BSD-style license.
   4 ;; See the file MLton-LICENSE for details.
   5
   6 ;; This is a minor mode to support precisely identified definitions and
   7 ;; uses.  See http://mlton.org/EmacsDefUseMode for further information.
   8
   9 ;; XXX def-use-apropos
  10 ;; XXX mode specific on-off switching
  11 ;; XXX rename-variable
  12
  13 (require 'def-use-data)
  14
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;; Prelude
  17
  18 (defvar def-use-load-time t)
  19
  20 (defun def-use-set-custom-and-update (sym val)
  21   (custom-set-default sym val)
  22   (unless def-use-load-time
  23     (def-use-update)))
  24
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 ;; Customization
  27
  28 (defgroup def-use nil
  29   "Minor mode to support precisely identified definitions and uses."
  30   :group 'matching)
  31
  32 (defface def-use-def-face
  33   '((((class color)) (:background "darkseagreen3"))
  34     (t (:background "gray")))
  35   "Face for highlighting definitions."
  36   :group 'faces
  37   :group 'def-use)
  38
  39 (defface def-use-unused-def-face
  40   '((((class color)) (:background "pink"))
  41     (t (:background "gray")))
  42   "Face for highlighting definitions that have no uses."
  43   :group 'faces
  44   :group 'def-use)
  45
  46 (defface def-use-use-face
  47   '((((class color)) (:background "paleturquoise3"))
  48     (t (:background "gray")))
  49   "Face for highlighting uses."
  50   :group 'faces
  51   :group 'def-use)
  52
  53 (defface def-use-mark-face
  54   '((((class color)) (:background "orchid1"))
  55     (t (:background "gray")))
  56   "Face for marking definitions and uses."
  57   :group 'faces
  58   :group 'def-use)
  59
  60 (defface def-use-view-face
  61   '((((class color)) (:background "chocolate1"))
  62     (t (:background "gray")))
  63   "Face for marking the definition or use currently being viewed."
  64   :group 'faces
  65   :group 'def-use)
  66
  67 (defcustom def-use-delay 0.125
  68   "Idle time in seconds to delay before updating highlighting or nil if
  69 you wish to disable highlighting.
  70
  71 Note that because highlighting runs on an idle timer, it may take a while
  72 before highlighting is first applied after it has been enabled by changing
  73 this customization variable. "
  74   :type '(choice
  75           (const :tag "disable" nil)
  76           (number :tag "seconds"))
  77   :set (function def-use-set-custom-and-update)
  78   :group 'def-use)
  79
  80 (defcustom def-use-priority 1000
  81   "Priority of highlighting overlays."
  82   :type 'integer
  83   :group 'def-use)
  84
  85 (defcustom def-use-marker-ring-length 16
  86   "*Length of marker ring `def-use-marker-ring'."
  87   :type 'integer
  88   :set (function def-use-set-custom-and-update)
  89   :group 'def-use)
  90
  91 (defcustom def-use-auto-show-symbol-messages t
  92   "Whether to show messages attached to symbols implicitly."
  93   :type '(choice
  94           (const :tag "disable" nil)
  95           (const :tag "enable" t))
  96   :group 'def-use)
  97
  98 (defcustom def-use-key-bindings
  99   '(("[(control c) (control d)]" . def-use-jump-to-def)
 100     ("[(control c) (control l)]" . def-use-list-all-refs)
 101     ("[(control c) (control m)]" . def-use-pop-ref-mark)
 102     ("[(control c) (control n)]" . def-use-jump-to-next)
 103     ("[(control c) (control p)]" . def-use-jump-to-prev)
 104     ("[(control c) (control s)]" . def-use-show-dus)
 105     ("[(control c) (control t)]" . def-use-show-msg)
 106     ("[(control c) (control v)]" . def-use-show-info))
 107   "Key bindings for the def-use mode.  The key specifications must be
 108 in a format accepted by the function `define-key'.  Hint: You might
 109 want to type `M-x describe-function def-use <TAB>' to see the
 110 available commands."
 111   :type '(repeat (cons :tag "Key Binding"
 112                        (string :tag "Key")
 113                        (function :tag "Command")))
 114   :set (function def-use-set-custom-and-update)
 115   :group 'def-use)
 116
 117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 118 ;; High-level symbol lookup
 119
 120 (defun def-use-sym-at-point (point &optional no-apology)
 121   "Returns symbol information for the symbol at the specified point."
 122   (let ((ref (def-use-ref-at-point point)))
 123     (when ref
 124       (def-use-sym-at-ref ref no-apology))))
 125
 126 (defun def-use-current-sym (&optional no-apology)
 127   "Returns symbol information for the symbol at the current point."
 128   (def-use-sym-at-point (point) no-apology))
 129
 130 (defun def-use-current-ref ()
 131   "Returns a reference to the symbol at the current point."
 132   (def-use-ref-at-point (point)))
 133
 134 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 135 ;; Navigation
 136
 137 (defvar def-use-marker-ring (make-ring def-use-marker-ring-length)
 138   "Ring of markers which are locations from which \\[def-use-jump-to-def],
 139 \\[def-use-jump-to-next], or \\[def-use-jump-to-prev] was invoked.")
 140
 141 (defun def-use-create-marker-ring ()
 142   (setq def-use-marker-ring
 143         (make-ring def-use-marker-ring-length)))
 144
 145 (defun def-use-pop-ref-mark ()
 146   "Pop back to where \\[def-use-jump-to-def], \\[def-use-jump-to-next], or
 147 \\[def-use-jump-to-prev] was last invoked."
 148   (interactive)
 149   (if (ring-empty-p def-use-marker-ring)
 150       (compat-error "No previous jump locations for invocation"))
 151   (let ((marker (ring-remove def-use-marker-ring 0)))
 152     (switch-to-buffer
 153      (or (marker-buffer marker)
 154          (compat-error "The marked buffer has been deleted")))
 155     (goto-char (marker-position marker))
 156     (set-marker marker nil nil)))
 157
 158 (defun def-use-jump-to-def (&optional other-window)
 159   "Jumps to the definition of the symbol under the cursor."
 160   (interactive "P")
 161   (let ((sym (def-use-current-sym)))
 162     (when sym
 163       (ring-insert def-use-marker-ring (point-marker))
 164       (def-use-goto-ref (def-use-sym-ref sym) other-window))))
 165
 166 (defun def-use-jump-to-next (&optional other-window reverse)
 167   "Jumps to the next use (or def) of the symbol under the cursor."
 168   (interactive "P")
 169   (let* ((ref (def-use-current-ref))
 170          (sym (def-use-sym-at-ref ref)))
 171     (when sym
 172       (let* ((refs (def-use-all-refs-sorted sym))
 173              (refs (if reverse (reverse refs) refs))
 174              (refs (append refs refs)))
 175         (while (not (equal (pop refs) ref)))
 176         (ring-insert def-use-marker-ring (point-marker))
 177         (def-use-goto-ref (car refs) other-window)))))
 178
 179 (defun def-use-jump-to-prev (&optional other-window)
 180   "Jumps to the prev use (or def) of the symbol under the cursor."
 181   (interactive "P")
 182   (def-use-jump-to-next other-window t))
 183
 184 (defun def-use-goto-ref (ref &optional other-window)
 185   "Finds the referenced source and moves point to the referenced
 186 position."
 187   (cond
 188    ((not (file-readable-p (def-use-ref-src ref)))
 189     (compat-error "Referenced file %s can not be read" (def-use-ref-src ref)))
 190    (other-window
 191     (def-use-find-file (def-use-ref-src ref) t))
 192    ((not (equal (def-use-buffer-file-truename) (def-use-ref-src ref)))
 193     (def-use-find-file (def-use-ref-src ref))))
 194   (def-use-goto-pos (def-use-ref-pos ref)))
 195
 196 (defun def-use-goto-pos (pos)
 197   "Moves point to the specified position."
 198   (goto-char (def-use-pos-to-point pos)))
 199
 200 (defun def-use-all-refs-sorted (sym)
 201   "Returns a sorted list of all references (including definition) to
 202 the symbol."
 203   (sort (cons (def-use-sym-ref sym)
 204               (copy-list (def-use-sym-to-uses sym)))
 205         (function def-use-ref<)))
 206
 207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 208 ;; List mode
 209
 210 (defconst def-use-ref-regexp "\\([^ ]+\\):\\([0-9]+\\)\\.\\([0-9]+\\)")
 211
 212 (defconst def-use-list-mode-map
 213   (let ((result (make-sparse-keymap)))
 214     (mapc (function
 215            (lambda (key-command)
 216              (define-key result
 217                (read (car key-command))
 218                (cdr key-command))))
 219           `(("[(b)]"      . ,(function bury-buffer))
 220             ("[(m)]"      . ,(function def-use-list-view-mark-all))
 221             ("[(u)]"      . ,(function def-use-list-view-unmark-all))
 222             ("[(q)]"      . ,(function def-use-kill-current-buffer))
 223             ("[(return)]" . ,(function def-use-list-view-ref))))
 224     result))
 225
 226 (define-derived-mode def-use-list-mode fundamental-mode "Def-Use-List"
 227   "Major mode for browsing def-use lists."
 228   :group 'def-use-list)
 229
 230 (defvar def-use-list-ref-to-overlay-alist nil)
 231 (defvar def-use-list-sym nil)
 232
 233 (defun def-use-list-all-refs (&optional reverse)
 234   "Lists all references to the symbol under the cursor."
 235   (interactive "P")
 236   (let* ((ref (def-use-current-ref))
 237          (sym (def-use-sym-at-ref ref)))
 238     (when sym
 239       (let* ((name (concat "<:" (def-use-format-sym sym) ":>"))
 240              (buffer (get-buffer name)))
 241         (if buffer
 242             (switch-to-buffer-other-window buffer)
 243           (setq buffer (get-buffer-create name))
 244           (switch-to-buffer-other-window buffer)
 245           (buffer-disable-undo)
 246           (def-use-list-mode)
 247           (compat-add-local-hook
 248             'kill-buffer-hook (function def-use-list-view-unmark-all))
 249           (set (make-local-variable 'def-use-list-sym)
 250                sym)
 251           (insert (def-use-format-sym sym) "\n"
 252                   "\n")
 253           (let* ((refs (def-use-all-refs-sorted sym))
 254                  (refs (if reverse (reverse refs) refs)))
 255             (set (make-local-variable 'def-use-list-ref-to-overlay-alist)
 256                  (mapcar (function list) refs))
 257             (mapc (function
 258                    (lambda (ref)
 259                      (insert (def-use-format-ref ref) "\n")))
 260                   refs))
 261           (goto-line 3)
 262           (setq buffer-read-only t))))))
 263
 264 (defun def-use-list-view-ref ()
 265   "Finds references on the current line and shows in another window."
 266   (interactive)
 267   (beginning-of-line)
 268   (let ((b (current-buffer))
 269         (idx (- (def-use-current-line) 3)))
 270     (when (and (<= 0 idx)
 271                (< idx (length def-use-list-ref-to-overlay-alist)))
 272       (forward-line)
 273       (def-use-goto-ref (car (nth idx def-use-list-ref-to-overlay-alist)) t)
 274       (switch-to-buffer-other-window b))))
 275
 276 (defun def-use-list-view-mark-all ()
 277   "Visits all the references and marks them."
 278   (interactive)
 279   (when (and def-use-list-ref-to-overlay-alist
 280              def-use-list-sym)
 281     (save-window-excursion
 282       (let ((length (length (def-use-sym-name def-use-list-sym))))
 283         (mapc (function
 284                (lambda (ref-overlay)
 285                  (unless (cdr ref-overlay)
 286                    (def-use-goto-ref (car ref-overlay) t)
 287                    (setcdr ref-overlay
 288                            (def-use-create-overlay
 289                              length
 290                              (def-use-ref-pos (car ref-overlay))
 291                              (- def-use-priority 1)
 292                              'def-use-mark-face)))))
 293               def-use-list-ref-to-overlay-alist)))))
 294
 295 (defun def-use-list-view-unmark-all ()
 296   "Kills all the marks associated with the list view."
 297   (interactive)
 298   (when def-use-list-ref-to-overlay-alist
 299     (mapc (function
 300            (lambda (ref-overlay)
 301              (when (cdr ref-overlay)
 302                (delete-overlay (cdr ref-overlay))
 303                (setcdr ref-overlay nil))))
 304           def-use-list-ref-to-overlay-alist)))
 305
 306 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 307 ;; Info
 308
 309 (defun def-use-show-msg (&optional copy-to-kill-ring)
 310   "Shows the message for the symbol under the cursor.  With a prefix
 311 argument the message is also inserted to the `kill-ring'."
 312   (interactive "P")
 313   (let ((sym (def-use-current-sym)))
 314     (when sym
 315       (message "%s" (or (def-use-sym-msg sym)
 316                         "Sorry, no message attached to the symbol."))
 317       (when (and (def-use-sym-msg sym))
 318         (kill-new (def-use-sym-msg sym))))))
 319
 320 (defun def-use-show-info ()
 321   "Shows info on the symbol under the cursor."
 322   (interactive)
 323   (let ((sym (def-use-current-sym)))
 324     (when sym
 325       (message "%s" (def-use-format-sym sym)))))
 326
 327 (defun def-use-format-sym (sym)
 328   "Formats a string with some basic info on the symbol."
 329   (concat (def-use-format-sym-title sym)
 330           ", "
 331           (number-to-string (length (def-use-sym-to-uses sym)))
 332           " uses, defined at: "
 333           (def-use-format-ref (def-use-sym-ref sym))))
 334
 335 (defun def-use-format-sym-title (sym)
 336   "Formats a title for the symbol"
 337   (concat (def-use-add-face 'font-lock-keyword-face
 338             (copy-sequence (def-use-sym-class sym)))
 339           " "
 340           (def-use-add-face (def-use-sym-face sym)
 341             (copy-sequence (def-use-sym-name sym)))
 342           (if (def-use-sym-msg sym)
 343               (concat " : " (def-use-sym-msg sym))
 344             "")))
 345
 346 (defun def-use-format-ref (ref)
 347   "Formats a references."
 348   (let ((pos (def-use-ref-pos ref)))
 349     (concat (def-use-ref-src ref)
 350             ":"
 351             (def-use-add-face 'font-lock-constant-face
 352               (number-to-string (def-use-pos-line pos)))
 353             "."
 354             (def-use-add-face 'font-lock-constant-face
 355               (number-to-string (def-use-pos-col pos))))))
 356
 357 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 358 ;; Highlighting
 359
 360 (defvar def-use-highlighted-sym nil)
 361 (defvar def-use-highlighted-buffer-file-truename nil)
 362 (defvar def-use-highlighted-overlays nil)
 363
 364 (defun def-use-delete-highlighting ()
 365   (mapc (function delete-overlay) def-use-highlighted-overlays)
 366   (setq def-use-highlighted-overlays nil
 367         def-use-highlighted-sym nil
 368         def-use-highlighted-buffer-file-truename nil))
 369
 370 (defun def-use-highlight-ref (sym ref face-attr)
 371   (push (def-use-create-overlay sym ref def-use-priority face-attr)
 372         def-use-highlighted-overlays))
 373
 374 (defun def-use-create-overlay (length pos priority face-attr)
 375   (let* ((begin (def-use-pos-to-point pos))
 376          (beyond (+ begin length))
 377          (overlay (make-overlay begin beyond)))
 378     (overlay-put overlay 'priority priority)
 379     (overlay-put overlay 'face face-attr)
 380     overlay))
 381
 382 (defun def-use-highlight-sym (sym)
 383   "Highlights the specified symbol."
 384   (let ((buffer-file-truename (def-use-buffer-file-truename)))
 385     (unless (and (equal def-use-highlighted-sym sym)
 386                  (equal def-use-highlighted-buffer-file-truename
 387                         buffer-file-truename))
 388       (def-use-delete-highlighting)
 389       (when sym
 390         (setq def-use-highlighted-sym sym
 391               def-use-highlighted-buffer-file-truename buffer-file-truename)
 392         (let ((length (length (def-use-sym-name sym)))
 393               (file-to-poss (def-use-make-hash-table)))
 394           (mapc (function
 395                  (lambda (ref)
 396                    (puthash (def-use-ref-src ref)
 397                             (cons (def-use-ref-pos ref)
 398                                   (gethash (def-use-ref-src ref) file-to-poss))
 399                             file-to-poss)))
 400                 (def-use-sym-to-uses sym))
 401           (mapc (function
 402                  (lambda (buffer)
 403                    (set-buffer buffer)
 404                    (mapc (function
 405                           (lambda (pos)
 406                             (def-use-highlight-ref
 407                              length pos 'def-use-use-face)))
 408                          (gethash
 409                           (def-use-buffer-file-truename) file-to-poss))))
 410                 (buffer-list))
 411           (let* ((ref (def-use-sym-ref sym))
 412                  (buffer
 413                   (def-use-find-buffer-visiting-file (def-use-ref-src ref))))
 414             (when buffer
 415               (set-buffer buffer)
 416               (def-use-highlight-ref
 417                 length (def-use-ref-pos ref)
 418                 (if (def-use-sym-to-uses sym)
 419                     'def-use-def-face
 420                   'def-use-unused-def-face)))))
 421         (when def-use-auto-show-symbol-messages
 422           (let ((msg (def-use-sym-msg sym)))
 423             (when msg
 424               (message "%s" msg))))))))
 425
 426 (defun def-use-highlight-current ()
 427   "Highlights the symbol at the point."
 428   (interactive)
 429   (save-excursion
 430     (save-window-excursion
 431       (def-use-highlight-sym (def-use-current-sym t)))))
 432
 433 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 434 ;; Highlighting timer
 435
 436 (defvar def-use-highlight-timer nil)
 437
 438 (defun def-use-delete-highlight-timer ()
 439   (when def-use-highlight-timer
 440     (compat-delete-timer def-use-highlight-timer)
 441     (setq def-use-highlight-timer nil)))
 442
 443 (defun def-use-create-highlight-timer ()
 444   (def-use-delete-highlight-timer)
 445   (when (and def-use-delay
 446              (def-use-mode-enabled-in-some-buffer))
 447     (setq def-use-highlight-timer
 448           (run-with-idle-timer
 449            def-use-delay t (function def-use-highlight-current)))))
 450
 451 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 452 ;; Mode
 453
 454 (defun def-use-mode-enabled-in-some-buffer ()
 455   (loop for buffer in (buffer-list) do
 456     (if (with-current-buffer buffer
 457           def-use-mode)
 458         (return t))))
 459
 460 (defvar def-use-mode-map (make-sparse-keymap)
 461   "Keymap for Def-Use mode.  This variable is updated by
 462 `def-use-build-mode-map'.")
 463
 464 (defun def-use-build-mode-map ()
 465   (let ((result (make-sparse-keymap)))
 466     (mapc (function
 467            (lambda (key-command)
 468              (define-key result (read (car key-command)) (cdr key-command))))
 469           def-use-key-bindings)
 470     (setq def-use-mode-map result))
 471   (let ((cons (assoc 'def-use-mode minor-mode-map-alist)))
 472     (when cons
 473       (setcdr cons def-use-mode-map))))
 474
 475 (define-minor-mode def-use-mode
 476   "Minor mode for highlighting and navigating definitions and uses.
 477
 478 \\{def-use-mode-map}
 479 "
 480   :lighter " DU"
 481   :group 'def-use
 482   :global t
 483   (def-use-delete-highlighting)
 484   (def-use-create-highlight-timer))
 485
 486 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 487 ;; Finalization
 488
 489 (setq def-use-load-time nil)
 490
 491 (defun def-use-update ()
 492   "Update data based on customization variables."
 493   (def-use-create-marker-ring)
 494   (def-use-create-highlight-timer)
 495   (def-use-build-mode-map))
 496
 497 (def-use-update)
 498
 499 (provide 'def-use-mode)