cgit.sxemacs.org Git - packages/blob - xemacs-packages/eieio/linemark.el

   1 ;;; linemark.el --- Manage groups of lines with marks.
   2 ;;
   3 ;; Author: Eric M. Ludlam <eludlam@mathworks.com>
   4 ;; Maintainer: Eric M. Ludlam <eludlam@mathworks.com>
   5 ;; Created: Dec 1999
   6 ;; Keywords: lisp
   7 ;;
   8 ;; Copyright (C) 1999, 2001, 2002, 2003, 2004, 2005, 2007 Eric M. Ludlam
   9 ;;
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24 ;;
  25 ;;; Commentary:
  26 ;;
  27 ;; This is a library of routines which help Lisp programmers manage
  28 ;; groups of marked lines.  Common uses for marked lines are debugger
  29 ;; breakpoints and watchpoints, or temporary line highlighting.  It
  30 ;; could also be used to select elements from a list.
  31 ;;
  32 ;; The reason this tool is useful is because cross-emacs overlay
  33 ;; management can be a pain, and overlays are certainly needed for use
  34 ;; with font-lock.
  35
  36 (require 'eieio)
  37
  38 ;;; Code:
  39 ;; Compatibility
  40 (eval-and-compile
  41   (if (featurep 'xemacs)
  42       (progn
  43         (defalias 'linemark-overlay-live-p 'extent-live-p)
  44         (defalias 'linemark-make-overlay 'make-extent)
  45         (defalias 'linemark-overlay-put 'set-extent-property)
  46         (defalias 'linemark-overlay-get 'extent-property)
  47         (defalias 'linemark-delete-overlay 'delete-extent)
  48         (defalias 'linemark-overlays-at
  49           (lambda (pos) (extent-list nil pos pos)))
  50         (defalias 'linemark-overlays-in
  51           (lambda (beg end) (extent-list nil beg end)))
  52         (defalias 'linemark-overlay-buffer 'extent-buffer)
  53         (defalias 'linemark-overlay-start 'extent-start-position)
  54         (defalias 'linemark-overlay-end 'extent-end-position)
  55         (defalias 'linemark-next-overlay-change 'next-extent-change)
  56         (defalias 'linemark-previous-overlay-change 'previous-extent-change)
  57         (defalias 'linemark-overlay-lists
  58           (lambda () (list (extent-list))))
  59         (defalias 'linemark-overlay-p 'extentp)
  60         )
  61     (defalias 'linemark-overlay-live-p 'overlay-buffer)
  62     (defalias 'linemark-make-overlay 'make-overlay)
  63     (defalias 'linemark-overlay-put 'overlay-put)
  64     (defalias 'linemark-overlay-get 'overlay-get)
  65     (defalias 'linemark-delete-overlay 'delete-overlay)
  66     (defalias 'linemark-overlays-at 'overlays-at)
  67     (defalias 'linemark-overlays-in 'overlays-in)
  68     (defalias 'linemark-overlay-buffer 'overlay-buffer)
  69     (defalias 'linemark-overlay-start 'overlay-start)
  70     (defalias 'linemark-overlay-end 'overlay-end)
  71     (defalias 'linemark-next-overlay-change 'next-overlay-change)
  72     (defalias 'linemark-previous-overlay-change 'previous-overlay-change)
  73     (defalias 'linemark-overlay-lists 'overlay-lists)
  74     (defalias 'linemark-overlay-p 'overlayp)
  75     ))
  76
  77 (defgroup linemark nil
  78   "Line marking/highlighting."
  79   :group 'tools
  80   )
  81
  82 (eval-and-compile
  83   ;; These faces need to exist to show up as valid default
  84   ;; entries in the classes defined below.
  85
  86 (defface linemark-stop-face '((((class color) (background light))
  87                                (:background "#ff8888"))
  88                               (((class color) (background dark))
  89                                (:background "red3")))
  90   "*Face used to indicate a STOP type line."
  91   :group 'linemark)
  92
  93 (defface linemark-caution-face '((((class color) (background light))
  94                                   (:background "yellow"))
  95                                  (((class color) (background dark))
  96                                   (:background "yellow4")))
  97   "*Face used to indicate a CAUTION type line."
  98   :group 'linemark)
  99
 100 (defface linemark-go-face '((((class color) (background light))
 101                              (:background "#88ff88"))
 102                             (((class color) (background dark))
 103                              (:background "green4")))
 104   "*Face used to indicate a GO, or OK type line."
 105   :group 'linemark)
 106
 107 (defface linemark-funny-face '((((class color) (background light))
 108                                 (:background "cyan"))
 109                                (((class color) (background dark))
 110                                 (:background "blue3")))
 111   "*Face used for elements with no particular criticality."
 112   :group 'linemark)
 113
 114 )
 115
 116 (defclass linemark-entry ()
 117   ((filename :initarg :filename
 118              :type string
 119              :documentation "File name for this mark.")
 120    (line     :initarg :line
 121              :type number
 122              :documentation "Line number where the mark is.")
 123    (face     :initarg :face
 124 ; Something created w/ defface is not a face in XEmacs.
 125 ;            :type face
 126              :initform linemark-caution-face
 127              :documentation "The face to use for display.")
 128    (parent   :documentation "The parent `linemark-group' containing this."
 129              :type linemark-group)
 130    (overlay  :documentation "Overlay created to show this mark."
 131              :type (or linemark-overlay null)
 132              :initform nil
 133              :protection protected))
 134   "Track a file/line associations with overlays used for display.")
 135
 136 (defclass linemark-group ()
 137   ((marks :initarg :marks
 138           :type list
 139           :initform nil
 140           :documentation "List of `linemark-entries'.")
 141    (face :initarg :face
 142          :initform linemark-funny-face
 143 ; Something created w/ defface is not a face in XEmacs.
 144 ;        :type (or null face)
 145          :documentation "Default face used to create new `linemark-entries'.")
 146    (active :initarg :active
 147            :type boolean
 148            :initform t
 149            :documentation "Track if these marks are active or not."))
 150   "Track a common group of `linemark-entries'.")
 151
 152 ;;; Functions
 153 ;;
 154 (defvar linemark-groups nil
 155   "List of groups we need to track.")
 156
 157 (defun linemark-create-group (name &optional defaultface)
 158   "*Obsolete*.
 159 Create a group object for tracking linemark entries.
 160 Do not permit multiple groups with the same NAME.
 161 Optional argument DEFAULTFACE is the :face slot for the object."
 162   (linemark-new-group 'linemark-group name :face defaultface)
 163   )
 164
 165 (defun linemark-new-group (class name &rest args)
 166   "Create a new linemark group based on the linemark CLASS.
 167 Give this group NAME.  ARGS are slot/value pairs for
 168 the new instantiation."
 169   (let ((newgroup nil)
 170         (foundgroup nil)
 171         (lmg linemark-groups))
 172     ;; Find an old group.
 173     (while (and (not foundgroup) lmg)
 174       (if (string= name (object-name-string (car lmg)))
 175           (setq foundgroup (car lmg)))
 176       (setq lmg (cdr lmg)))
 177     ;; Which group to use.
 178     (if foundgroup
 179         ;; Recycle the old group
 180         (setq newgroup foundgroup)
 181       ;; Create a new group
 182       (setq newgroup (apply 'make-instance class name args))
 183       (setq linemark-groups (cons newgroup linemark-groups)))
 184     ;; Return the group
 185     newgroup))
 186
 187 (defun linemark-at-point (&optional pos group)
 188   "Return the current variable `linemark-entry' at point.
 189 Optional POS is the position to check which defaults to point.
 190 If GROUP, then make sure it also belongs to GROUP."
 191   (if (not pos) (setq pos (point)))
 192   (let ((o (linemark-overlays-at pos))
 193         (found nil))
 194     (while (and o (not found))
 195       (let ((og (linemark-overlay-get (car o) 'obj)))
 196         (if (and og (linemark-entry-child-p og))
 197             (progn
 198               (setq found og)
 199               (if group
 200                   (if (not (eq group (oref found parent)))
 201                       (setq found nil)))))
 202         (setq o (cdr o))))
 203     found))
 204
 205 (defun linemark-next-in-buffer (group &optional arg wrap)
 206   "Return the next mark in this buffer belonging to GROUP.
 207 If ARG, then find that manu marks forward or backward.
 208 Optional WRAP argument indicates that we should wrap around the end of
 209 the buffer."
 210   (if (not arg) (setq arg 1)) ;; default is one forward
 211   (let* ((entry (linemark-at-point (point) group))
 212          (nc (if entry
 213                  (if (< 0 arg) (linemark-end entry)
 214                    (linemark-begin entry))
 215                (point)))
 216          (oll nil)
 217          (dir (if (< 0 arg) 1 -1))
 218          (ofun (if (> 0 arg)
 219                    'linemark-previous-overlay-change
 220                  'linemark-next-overlay-change))
 221          (bounds (if (< 0 arg) (point-min) (point-max)))
 222          )
 223     (setq entry nil)
 224     (catch 'moose
 225       (save-excursion
 226         (while (and (not entry) (/= arg 0))
 227           (setq nc (funcall ofun nc))
 228           (setq entry (linemark-at-point nc group))
 229           (if (not entry)
 230               (if (or (= nc (point-min)) (= nc (point-max)))
 231                   (if (not wrap)
 232                       (throw 'moose t)
 233                     (setq wrap nil ;; only wrap once
 234                           nc bounds))))
 235           ;; Ok, now decrement arg, and keep going.
 236           (if entry
 237               (setq arg (- arg dir)
 238                     nc (linemark-end entry))))))
 239     entry))
 240
 241 ;;; Methods that make things go
 242 ;;
 243 (defmethod linemark-add-entry ((g linemark-group) &rest args)
 244   "Add a `linemark-entry' to G.
 245 It will be at location specified by :filename and :line, and :face
 246 which are property list entries in ARGS.
 247 Call the new entrie's activate method."
 248   (let ((file (plist-get args :filename))
 249         (line (plist-get args :line))
 250         (face (plist-get args :face)))
 251     (if (not file)
 252         (progn
 253           (setq file (buffer-file-name))
 254           (if file
 255               (setq file (expand-file-name file))
 256             (setq file (buffer-name)))))
 257     (when (not line)
 258       (setq line (count-lines (point-min) (point)))
 259       (if (bolp) (setq line (1+ line))))
 260     (setq args (plist-put args :filename file))
 261     (setq args (plist-put args :line line))
 262     (let ((new-entry (apply 'linemark-new-entry g args)))
 263       (oset new-entry parent g)
 264       (oset new-entry face (or face (oref g face)))
 265       (oset g marks (cons new-entry (oref g marks)))
 266       (if (oref g active)
 267             (linemark-display new-entry t))
 268       new-entry)
 269     ))
 270
 271 (defmethod linemark-new-entry ((g linemark-group) &rest args)
 272   "Create a new entry for G using init ARGS."
 273   (let ((f (plist-get args :filename))
 274         (l (plist-get args :line)))
 275     (apply 'linemark-entry (format "%s %d" f l)
 276            args)))
 277
 278 (defmethod linemark-display ((g linemark-group) active-p)
 279   "Set object G to be active or inactive."
 280   (mapcar (lambda (g) (linemark-display g active-p)) (oref g marks))
 281   (oset g active active-p))
 282
 283 (defmethod linemark-display ((e linemark-entry) active-p)
 284   "Set object E to be active or inactive."
 285   (if active-p
 286       (with-slots ((file filename)) e
 287         (if (oref e overlay)
 288             ;; Already active
 289             nil
 290           (let ((buffer))
 291             (if (get-file-buffer file)
 292                 (setq buffer (get-file-buffer file))
 293               (setq buffer (get-buffer file)))
 294             (if buffer
 295                 (save-excursion
 296                   (set-buffer buffer)
 297                   (save-excursion
 298                     (goto-line (oref e line))
 299                     (beginning-of-line)
 300                     (oset e overlay
 301                           (linemark-make-overlay (point)
 302                                                  (save-excursion
 303                                                    (end-of-line) (point))
 304                                                  (current-buffer)))
 305                     (with-slots (overlay) e
 306                       (linemark-overlay-put overlay 'face (oref e face))
 307                       (linemark-overlay-put overlay 'obj e)
 308                       (linemark-overlay-put overlay 'tag 'linemark))))))))
 309     ;; Not active
 310     (with-slots (overlay) e
 311       (if overlay
 312           (progn
 313             (condition-case nil
 314                 ;; During development of linemark programs, this is helpful
 315                 (linemark-delete-overlay overlay)
 316               (error nil))
 317             (oset e overlay nil))))))
 318
 319 (defmethod linemark-delete ((g linemark-group))
 320   "Remove group G from linemark tracking."
 321   (mapcar 'linemark-delete (oref g marks))
 322   (setq linemark-groups (delete g linemark-groups)))
 323
 324 (defmethod linemark-delete ((e linemark-entry))
 325   "Remove entry E from it's parent group."
 326   (with-slots (parent) e
 327     (oset parent marks (delq e (oref parent marks)))
 328     (linemark-display e nil)))
 329
 330 (defmethod linemark-begin ((e linemark-entry))
 331   "Position at the start of the entry E."
 332   (with-slots (overlay) e
 333     (linemark-overlay-start overlay)))
 334
 335 (defmethod linemark-end ((e linemark-entry))
 336   "Position at the end of the entry E."
 337   (with-slots (overlay) e
 338     (linemark-overlay-end overlay)))
 339
 340 ;;; Trans buffer tracking
 341 ;;
 342 ;; This section sets up a find-file-hook and a kill-buffer-hook
 343 ;; so that marks that aren't displayed (because the buffer doesn't
 344 ;; exist) are displayed when said buffer appears, and that overlays
 345 ;; are removed when the buffer buffer goes away.
 346
 347 (defun linemark-find-file-hook ()
 348   "Activate all marks which can benifit from this new buffer."
 349   (mapcar (lambda (g) (linemark-display g t)) linemark-groups))
 350
 351 (defun linemark-kill-buffer-hook ()
 352   "Deactivate all entries in the current buffer."
 353   (let ((o (linemark-overlays-in (point-min) (point-max)))
 354         (to nil))
 355     (while o
 356       (setq to (linemark-overlay-get (car o) 'obj))
 357       (if (and to (linemark-entry-child-p to))
 358           (linemark-display to nil))
 359       (setq o (cdr o)))))
 360
 361 (add-hook 'find-file-hooks 'linemark-find-file-hook)
 362 (add-hook 'kill-buffer-hook 'linemark-kill-buffer-hook)
 363
 364 ;;; Demo mark tool: Emulate MS Visual Studio bookmarks
 365 ;;
 366 (defvar viss-bookmark-group (linemark-new-group 'linemark-group "viss")
 367   "The VISS bookmark group object.")
 368
 369 (defun viss-bookmark-toggle ()
 370   "Toggle a bookmark on the current line."
 371   (interactive)
 372   (let ((ce (linemark-at-point (point) viss-bookmark-group)))
 373     (if ce
 374         (linemark-delete ce)
 375       (linemark-add-entry viss-bookmark-group))))
 376
 377 (defun viss-bookmark-next-buffer ()
 378   "Move to the next bookmark in this buffer."
 379   (interactive)
 380   (let ((n (linemark-next-in-buffer viss-bookmark-group 1 t)))
 381     (if n (goto-line (oref n line)) (ding))))
 382
 383 (defun viss-bookmark-prev-buffer ()
 384   "Move to the next bookmark in this buffer."
 385   (interactive)
 386   (let ((n (linemark-next-in-buffer viss-bookmark-group -1 t)))
 387     (if n (goto-line (oref n line)) (ding))))
 388
 389 (defun viss-bookmark-clear-all-buffer ()
 390   "Clear all bookmarks in this buffer."
 391   (interactive)
 392   (mapcar (lambda (e)
 393             (if (or (string= (oref e filename) (buffer-file-name))
 394                     (string= (oref e filename) (buffer-name)))
 395                 (linemark-delete e)))
 396           (oref viss-bookmark-group marks)))
 397
 398 ;; These functions only sort of worked and were not really useful to me.
 399 ;;
 400 ;;(defun viss-bookmark-next ()
 401 ;;  "Move to the next bookmark."
 402 ;;  (interactive)
 403 ;;  (let ((c (linemark-at-point (point) viss-bookmark-group))
 404 ;;        (n nil))
 405 ;;    (if c
 406 ;;        (let ((n (member c (oref viss-bookmark-group marks))))
 407 ;;          (if n (setq n (car (cdr n)))
 408 ;;            (setq n (car (oref viss-bookmark-group marks))))
 409 ;;          (if n (goto-line (oref n line)) (ding)))
 410 ;;      ;; if no current mark, then just find a local one.
 411 ;;      (viss-bookmark-next-buffer))))
 412 ;;
 413 ;;(defun viss-bookmark-prev ()
 414 ;;  "Move to the next bookmark."
 415 ;;  (interactive)
 416 ;;  (let ((c (linemark-at-point (point) viss-bookmark-group))
 417 ;;        (n nil))
 418 ;;    (if c
 419 ;;        (let* ((marks (oref viss-bookmark-group marks))
 420 ;;               (n (member c marks)))
 421 ;;          (if n
 422 ;;              (setq n (- (- (length marks) (length n)) 1))
 423 ;;            (setq n (car marks)))
 424 ;;          (if n (goto-line (oref n line)) (ding)))
 425 ;;      ;; if no current mark, then just find a local one.
 426 ;;      (viss-bookmark-prev-buffer))))
 427 ;;
 428 ;;(defun viss-bookmark-clear-all ()
 429 ;;  "Clear all viss bookmarks."
 430 ;;  (interactive)
 431 ;;  (mapcar (lambda (e) (linemark-delete e))
 432 ;;          (oref viss-bookmark-group marks)))
 433 ;;
 434
 435 ;;;###autoload
 436 (defun enable-visual-studio-bookmarks ()
 437   "Bind the viss bookmark functions to F2 related keys.
 438 \\<global-map>
 439 \\[viss-bookmark-toggle]     - To=ggle a bookmark on this line.
 440 \\[viss-bookmark-next-buffer]   - Move to the next bookmark.
 441 \\[viss-bookmark-prev-buffer]   - Move to the previous bookmark.
 442 \\[viss-bookmark-clear-all-buffer] - Clear all bookmarks."
 443   (interactive)
 444   (define-key global-map [(f2)] 'viss-bookmark-toggle)
 445   (define-key global-map [(shift f2)] 'viss-bookmark-prev-buffer)
 446   (define-key global-map [(control f2)] 'viss-bookmark-next-buffer)
 447   (define-key global-map [(control shift f2)] 'viss-bookmark-clear-all-buffer)
 448 )
 449
 450 (provide 'linemark)
 451
 452 ;;; linemark.el ends here