easy-mmode.el 23 KB
Newer Older
1
;;; easy-mmode.el --- easy definition for major and minor modes
Richard M. Stallman's avatar
Richard M. Stallman committed
2

3
;; Copyright (C) 1997, 2000-2011  Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
4

Pavel Janík's avatar
Pavel Janík committed
5 6
;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr>
;; Maintainer: Stefan Monnier <monnier@gnu.org>
7
;; Package: emacs
Pavel Janík's avatar
Pavel Janík committed
8 9

;; Keywords: extensions lisp
Richard M. Stallman's avatar
Richard M. Stallman committed
10 11 12

;; This file is part of GNU Emacs.

13
;; GNU Emacs is free software: you can redistribute it and/or modify
Richard M. Stallman's avatar
Richard M. Stallman committed
14
;; it under the terms of the GNU General Public License as published by
15 16
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Richard M. Stallman's avatar
Richard M. Stallman committed
17 18 19 20 21 22 23

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
24
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Richard M. Stallman's avatar
Richard M. Stallman committed
25 26 27 28 29 30 31 32 33 34 35 36

;;; Commentary:

;; Minor modes are useful and common.  This package makes defining a
;; minor mode easy, by focusing on the writing of the minor mode
;; functionalities themselves.  Moreover, this package enforces a
;; conventional naming of user interface primitives, making things
;; natural for the minor-mode end-users.

;; For each mode, easy-mmode defines the following:
;; <mode>      : The minor mode predicate. A buffer-local variable.
;; <mode>-map  : The keymap possibly associated to <mode>.
37
;;       see `define-minor-mode' documentation
Richard M. Stallman's avatar
Richard M. Stallman committed
38 39
;;
;; eval
40
;;  (pp (macroexpand '(define-minor-mode <your-mode> <doc>)))
Richard M. Stallman's avatar
Richard M. Stallman committed
41 42 43 44 45 46 47 48
;; to check the result before using it.

;; The order in which minor modes are installed is important.  Keymap
;; lookup proceeds down minor-mode-map-alist, and the order there
;; tends to be the reverse of the order in which the modes were
;; installed.  Perhaps there should be a feature to let you specify
;; orderings.

49 50
;; Additionally to `define-minor-mode', the package provides convenient
;; ways to define keymaps, and other helper functions for major and minor modes.
Richard M. Stallman's avatar
Richard M. Stallman committed
51

52
;;; Code:
Richard M. Stallman's avatar
Richard M. Stallman committed
53

54 55
(eval-when-compile (require 'cl))

56 57
(defun easy-mmode-pretty-mode-name (mode &optional lighter)
  "Turn the symbol MODE into a string intended for the user.
58 59
If provided, LIGHTER will be used to help choose capitalization by,
replacing its case-insensitive matches with the literal string in LIGHTER."
60
  (let* ((case-fold-search t)
61
	 ;; Produce "Foo-Bar minor mode" from foo-bar-minor-mode.
62
	 (name (concat (replace-regexp-in-string
63 64 65
			;; If the original mode name included "-minor" (some
			;; of them don't, e.g. auto-revert-mode), then
			;; replace it with " minor".
66
			"-Minor" " minor"
67
			;; "foo-bar-minor" -> "Foo-Bar-Minor"
68
			(capitalize (replace-regexp-in-string
69
				     ;; "foo-bar-minor-mode" -> "foo-bar-minor"
70
				     "-mode\\'" "" (symbol-name mode))))
71 72
		       " mode")))
    (if (not (stringp lighter)) name
73 74 75 76 77 78 79 80 81 82
      ;; Strip leading and trailing whitespace from LIGHTER.
      (setq lighter (replace-regexp-in-string "\\`\\s-+\\|\\s-+\\'" ""
					      lighter))
      ;; Replace any (case-insensitive) matches for LIGHTER in NAME
      ;; with a literal LIGHTER.  E.g., if NAME is "Iimage mode" and
      ;; LIGHTER is " iImag", then this will produce "iImage mode".
      ;; (LIGHTER normally comes from the mode-line string passed to
      ;; define-minor-mode, and normally includes at least one leading
      ;; space.)
      (replace-regexp-in-string (regexp-quote lighter) lighter name t t))))
83

Richard M. Stallman's avatar
Richard M. Stallman committed
84
;;;###autoload
Stefan Monnier's avatar
Stefan Monnier committed
85 86 87
(defalias 'easy-mmode-define-minor-mode 'define-minor-mode)
;;;###autoload
(defmacro define-minor-mode (mode doc &optional init-value lighter keymap &rest body)
Richard M. Stallman's avatar
Richard M. Stallman committed
88
  "Define a new minor mode MODE.
89
This defines the control variable MODE and the toggle command MODE.
Richard M. Stallman's avatar
Richard M. Stallman committed
90
DOC is the documentation for the mode toggle command.
91

Stefan Monnier's avatar
Stefan Monnier committed
92
Optional INIT-VALUE is the initial value of the mode's variable.
93
Optional LIGHTER is displayed in the modeline when the mode is on.
94 95
Optional KEYMAP is the default keymap bound to the mode keymap.
  If non-nil, it should be a variable name (whose value is a keymap),
96
  or an expression that returns either a keymap or a list of
97 98 99
  arguments for `easy-mmode-define-keymap'.  If you supply a KEYMAP
  argument that is not a symbol, this macro defines the variable
  MODE-map and gives it the value that KEYMAP specifies.
100 101 102 103 104 105 106 107

BODY contains code to execute each time the mode is enabled or disabled.
  It is executed after toggling the mode, and before running MODE-hook.
  Before the actual body code, you can write keyword arguments, i.e.
  alternating keywords and values.  These following special keywords
  are supported (other keywords are passed to `defcustom' if the minor
  mode is global):

108
:group GROUP	Custom group name to use in all generated `defcustom' forms.
109
		Defaults to MODE without the possible trailing \"-mode\".
110 111
		Don't use this default group name unless you have written a
		`defgroup' to define that group properly.
112
:global GLOBAL	If non-nil specifies that the minor mode is not meant to be
113
		buffer-local, so don't make the variable MODE buffer-local.
114
		By default, the mode is buffer-local.
115 116
:init-value VAL	Same as the INIT-VALUE argument.
:lighter SPEC	Same as the LIGHTER argument.
117
:keymap MAP	Same as the KEYMAP argument.
118
:require SYM	Same as in `defcustom'.
119
:variable PLACE	The location (as can be used with `setf') to use instead
120 121 122
		of the variable MODE to store the state of the mode.  PLACE
		can also be of the form (GET . SET) where GET is an expression
		that returns the current state and SET is a function that takes
123 124
		a new state and sets it.  If you specify a :variable, this
		function assumes it is defined elsewhere.
125 126 127

For example, you could write
  (define-minor-mode foo-mode \"If enabled, foo on you!\"
128
    :lighter \" Foo\" :require 'foo :global t :group 'hassle :version \"27.5\"
129
    ...BODY CODE...)"
130 131 132 133 134 135
  (declare (debug (&define name stringp
			   [&optional [&not keywordp] sexp
			    &optional [&not keywordp] sexp
			    &optional [&not keywordp] sexp]
			   [&rest [keywordp sexp]]
			   def-body)))
136

Stefan Monnier's avatar
Stefan Monnier committed
137 138 139 140 141 142 143 144 145
  ;; Allow skipping the first three args.
  (cond
   ((keywordp init-value)
    (setq body (list* init-value lighter keymap body)
	  init-value nil lighter nil keymap nil))
   ((keywordp lighter)
    (setq body (list* lighter keymap body) lighter nil keymap nil))
   ((keywordp keymap) (push keymap body) (setq keymap nil)))

146 147
  (let* ((last-message (make-symbol "last-message"))
         (mode-name (symbol-name mode))
148
	 (pretty-name (easy-mmode-pretty-mode-name mode lighter))
149
	 (globalp nil)
150
	 (set nil)
151
	 (initialize nil)
152
	 (group nil)
153
	 (type nil)
154
	 (extra-args nil)
155
	 (extra-keywords nil)
156 157 158
         (variable nil)          ;The PLACE where the state is stored.
         (setter nil)            ;The function (if any) to set the mode var.
         (modefun mode)          ;The minor mode function name we're defining.
159
	 (require t)
160 161
	 (hook (intern (concat mode-name "-hook")))
	 (hook-on (intern (concat mode-name "-on-hook")))
162
	 (hook-off (intern (concat mode-name "-off-hook")))
163
	 keyw keymap-sym)
164 165

    ;; Check keys.
166 167 168
    (while (keywordp (setq keyw (car body)))
      (setq body (cdr body))
      (case keyw
Stefan Monnier's avatar
Stefan Monnier committed
169
	(:init-value (setq init-value (pop body)))
170
	(:lighter (setq lighter (purecopy (pop body))))
171
	(:global (setq globalp (pop body)))
172
	(:extra-args (setq extra-args (pop body)))
173
	(:set (setq set (list :set (pop body))))
174
	(:initialize (setq initialize (list :initialize (pop body))))
175
	(:group (setq group (nconc group (list :group (pop body)))))
176
	(:type (setq type (list :type (pop body))))
177
	(:require (setq require (pop body)))
178
	(:keymap (setq keymap (pop body)))
179 180 181 182 183 184
        (:variable (setq variable (pop body))
         (if (not (functionp (cdr-safe variable)))
             ;; PLACE is not of the form (GET . SET).
             (setq mode variable)
           (setq mode (car variable))
           (setq setter (cdr variable))))
185
	(t (push keyw extra-keywords) (push (pop body) extra-keywords))))
186

187 188 189
    (setq keymap-sym (if (and keymap (symbolp keymap)) keymap
		       (intern (concat mode-name "-map"))))

190 191
    (unless set (setq set '(:set 'custom-set-minor-mode)))

192
    (unless initialize
193
      (setq initialize '(:initialize 'custom-initialize-default)))
194

195 196 197
    (unless group
      ;; We might as well provide a best-guess default group.
      (setq group
198 199
	    `(:group ',(intern (replace-regexp-in-string
				"-mode\\'" "" mode-name)))))
200

201
    ;; TODO? Mark booleans as safe if booleanp?  Eg abbrev-mode.
202 203
    (unless type (setq type '(:type 'boolean)))

Richard M. Stallman's avatar
Richard M. Stallman committed
204
    `(progn
Karl Heuer's avatar
Karl Heuer committed
205
       ;; Define the variable to enable or disable the mode.
206 207 208 209 210 211 212
       ,(cond
         ;; If :variable is specified, then the var will be
         ;; declared elsewhere.
         (variable nil)
         ((not globalp)
          `(progn
             (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled.
213
Use the command `%s' to change this variable." pretty-name mode))
214 215
             (make-variable-buffer-local ',mode)))
         (t
216 217
	  (let ((base-doc-string
                 (concat "Non-nil if %s is enabled.
218
See the command `%s' for a description of this minor mode."
219
                         (if body "
220
Setting this variable directly does not take effect;
221 222
either customize it (see the info node `Easy Customization')
or call the function `%s'."))))
223 224
	    `(defcustom ,mode ,init-value
	       ,(format base-doc-string pretty-name mode mode)
225
	       ,@set
226
	       ,@initialize
227
	       ,@group
228
	       ,@type
229
	       ,@(unless (eq require t) `(:require ,require))
230
               ,@(nreverse extra-keywords)))))
231

232
       ;; The actual function.
233
       (defun ,modefun (&optional arg ,@extra-args)
234
	 ,(or doc
Stefan Monnier's avatar
Stefan Monnier committed
235 236
	      (format (concat "Toggle %s on or off.
Interactively, with no prefix argument, toggle the mode.
237
With universal prefix ARG turn mode on.
238
With zero or negative ARG turn mode off.
Stefan Monnier's avatar
Stefan Monnier committed
239
\\{%s}") pretty-name keymap-sym))
240 241 242
	 ;; Use `toggle' rather than (if ,mode 0 1) so that using
	 ;; repeat-command still does the toggling correctly.
	 (interactive (list (or current-prefix-arg 'toggle)))
243
	 (let ((,last-message (current-message)))
244 245
           (,@(if setter (list setter)
                (list (if (symbolp mode) 'setq 'setf) mode))
246 247 248 249
            (if (eq arg 'toggle)
                (not ,mode)
              ;; A nil argument also means ON now.
              (> (prefix-numeric-value arg) 0)))
250 251 252
           ,@body
           ;; The on/off hooks are here for backward compatibility only.
           (run-hooks ',hook (if ,mode ',hook-on ',hook-off))
253
           (if (called-interactively-p 'any)
254
               (progn
255 256
                 ,(if (and globalp (symbolp mode))
                      `(customize-mark-as-set ',mode))
257 258 259 260 261 262 263
                 ;; Avoid overwriting a message shown by the body,
                 ;; but do overwrite previous messages.
                 (unless (and (current-message)
                              (not (equal ,last-message
                                          (current-message))))
                   (message ,(format "%s %%sabled" pretty-name)
                            (if ,mode "en" "dis"))))))
Stefan Monnier's avatar
Stefan Monnier committed
264
	 (force-mode-line-update)
265
	 ;; Return the new setting.
266
	 ,mode)
267

268 269
       ;; Autoloading a define-minor-mode autoloads everything
       ;; up-to-here.
270 271
       :autoload-end

272
       ;; Define the minor-mode keymap.
273
       ,(unless (symbolp keymap)	;nil is also a symbol.
274
	  `(defvar ,keymap-sym
275 276 277
	     (let ((m ,keymap))
	       (cond ((keymapp m) m)
		     ((listp m) (easy-mmode-define-keymap m))
278
		     (t (error "Invalid keymap %S" m))))
279 280
	     ,(format "Keymap for `%s'." mode-name)))

281 282 283 284 285
       ,(if (not (symbolp mode))
            (if (or lighter keymap)
                (error ":lighter and :keymap unsupported with mode expression %s" mode))
          `(with-no-warnings
             (add-minor-mode ',mode ',lighter
286
                           ,(if keymap keymap-sym
287 288 289
                                `(if (boundp ',keymap-sym) ,keymap-sym))
                             nil
                             ,(unless (eq mode modefun) 'modefun)))))))
290

291 292 293 294
;;;
;;; make global minor mode
;;;

295
;;;###autoload
296
(defalias 'easy-mmode-define-global-mode 'define-globalized-minor-mode)
297
;;;###autoload
298 299 300
(defalias 'define-global-minor-mode 'define-globalized-minor-mode)
;;;###autoload
(defmacro define-globalized-minor-mode (global-mode mode turn-on &rest keys)
301
  "Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE.
302 303
TURN-ON is a function that will be called with no args in every buffer
  and that should try to turn MODE on if applicable for that buffer.
304 305 306 307 308 309
KEYS is a list of CL-style keyword arguments.  As the minor mode
  defined by this function is always global, any :global keyword is
  ignored.  Other keywords have the same meaning as in `define-minor-mode',
  which see.  In particular, :group specifies the custom group.
  The most useful keywords are those that are passed on to the
  `defcustom'.  It normally makes no sense to pass the :lighter
310
  or :keymap keywords to `define-globalized-minor-mode', since these
311
  are usually passed to the buffer-local version of the minor mode.
312 313 314 315 316 317 318

If MODE's set-up depends on the major mode in effect when it was
enabled, then disabling and reenabling MODE should make MODE work
correctly with the current major mode.  This is important to
prevent problems with derived modes, that is, major modes that
call another major mode in their body."

319
  (let* ((global-mode-name (symbol-name global-mode))
320 321
	 (pretty-name (easy-mmode-pretty-mode-name mode))
	 (pretty-global-name (easy-mmode-pretty-mode-name global-mode))
322
	 (group nil)
323
	 (extra-keywords nil)
324 325 326 327 328 329
	 (MODE-buffers (intern (concat global-mode-name "-buffers")))
	 (MODE-enable-in-buffers
	  (intern (concat global-mode-name "-enable-in-buffers")))
	 (MODE-check-buffers
	  (intern (concat global-mode-name "-check-buffers")))
	 (MODE-cmhh (intern (concat global-mode-name "-cmhh")))
330 331
	 (MODE-major-mode (intern (concat (symbol-name mode) "-major-mode")))
	 keyw)
332 333

    ;; Check keys.
334 335 336
    (while (keywordp (setq keyw (car keys)))
      (setq keys (cdr keys))
      (case keyw
337
	(:group (setq group (nconc group (list :group (pop keys)))))
338 339
	(:global (setq keys (cdr keys)))
	(t (push keyw extra-keywords) (push (pop keys) extra-keywords))))
340

341 342 343
    (unless group
      ;; We might as well provide a best-guess default group.
      (setq group
344 345
	    `(:group ',(intern (replace-regexp-in-string
				"-mode\\'" "" (symbol-name mode))))))
346

347
    `(progn
348 349
       (defvar ,MODE-major-mode nil)
       (make-variable-buffer-local ',MODE-major-mode)
350 351
       ;; The actual global minor-mode
       (define-minor-mode ,global-mode
352 353
	 ;; Very short lines to avoid too long lines in the generated
	 ;; doc string.
354 355 356 357 358
	 ,(format "Toggle %s in all buffers.
With prefix ARG, enable %s if ARG is positive;
otherwise, disable it.  If called from Lisp, enable the mode if
ARG is omitted or nil.

359 360
%s is enabled in all buffers where
\`%s' would do it.
361
See `%s' for more information on %s."
362 363
		  pretty-name pretty-global-name
		  pretty-name turn-on mode pretty-name)
364
	 :global t ,@group ,@(nreverse extra-keywords)
365 366 367

	 ;; Setup hook to handle future mode changes and new buffers.
	 (if ,global-mode
368
	     (progn
369 370
	       (add-hook 'after-change-major-mode-hook
			 ',MODE-enable-in-buffers)
371
	       (add-hook 'fundamental-mode-hook ',MODE-enable-in-buffers)
372 373 374
	       (add-hook 'find-file-hook ',MODE-check-buffers)
	       (add-hook 'change-major-mode-hook ',MODE-cmhh))
	   (remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers)
375
           (remove-hook 'fundamental-mode-hook ',MODE-enable-in-buffers)
376 377
	   (remove-hook 'find-file-hook ',MODE-check-buffers)
	   (remove-hook 'change-major-mode-hook ',MODE-cmhh))
378 379 380 381

	 ;; Go through existing buffers.
	 (dolist (buf (buffer-list))
	   (with-current-buffer buf
382
	     (if ,global-mode (,turn-on) (when ,mode (,mode -1))))))
383

384
       ;; Autoloading define-globalized-minor-mode autoloads everything
385
       ;; up-to-here.
386 387
       :autoload-end

388
       ;; List of buffers left to process.
389
       (defvar ,MODE-buffers nil)
390 391

       ;; The function that calls TURN-ON in each buffer.
392 393 394 395
       (defun ,MODE-enable-in-buffers ()
	 (dolist (buf ,MODE-buffers)
	   (when (buffer-live-p buf)
	     (with-current-buffer buf
396 397 398 399 400 401 402 403
               (unless (eq ,MODE-major-mode major-mode)
                 (if ,mode
                     (progn
                       (,mode -1)
                       (,turn-on)
                       (setq ,MODE-major-mode major-mode))
                   (,turn-on)
                   (setq ,MODE-major-mode major-mode)))))))
404 405 406 407 408 409 410
       (put ',MODE-enable-in-buffers 'definition-name ',global-mode)

       (defun ,MODE-check-buffers ()
	 (,MODE-enable-in-buffers)
	 (setq ,MODE-buffers nil)
	 (remove-hook 'post-command-hook ',MODE-check-buffers))
       (put ',MODE-check-buffers 'definition-name ',global-mode)
411 412

       ;; The function that catches kill-all-local-variables.
413 414 415 416
       (defun ,MODE-cmhh ()
	 (add-to-list ',MODE-buffers (current-buffer))
	 (add-hook 'post-command-hook ',MODE-check-buffers))
       (put ',MODE-cmhh 'definition-name ',global-mode))))
417

418 419 420 421
;;;
;;; easy-mmode-defmap
;;;

422 423 424 425 426 427 428 429 430 431 432 433
(eval-and-compile
  (if (fboundp 'set-keymap-parents)
      (defalias 'easy-mmode-set-keymap-parents 'set-keymap-parents)
    (defun easy-mmode-set-keymap-parents (m parents)
      (set-keymap-parent
       m
       (cond
        ((not (consp parents)) parents)
        ((not (cdr parents)) (car parents))
        (t (let ((m (copy-keymap (pop parents))))
             (easy-mmode-set-keymap-parents m parents)
             m)))))))
434

435
;;;###autoload
436 437 438
(defun easy-mmode-define-keymap (bs &optional name m args)
  "Return a keymap built from bindings BS.
BS must be a list of (KEY . BINDING) where
439 440 441
KEY and BINDINGS are suitable for `define-key'.
Optional NAME is passed to `make-sparse-keymap'.
Optional map M can be used to modify an existing map.
442 443 444 445 446 447 448 449 450 451 452
ARGS is a list of additional keyword arguments.

Valid keywords and arguments are:

  :name      Name of the keymap; overrides NAME argument.
  :dense     Non-nil for a dense keymap.
  :inherit   Parent keymap.
  :group     Ignored.
  :suppress  Non-nil to call `suppress-keymap' on keymap,
             'nodigits to suppress digits as prefix arguments."
  (let (inherit dense suppress)
453 454 455
    (while args
      (let ((key (pop args))
	    (val (pop args)))
456
	(case key
Stefan Monnier's avatar
Stefan Monnier committed
457
	 (:name (setq name val))
458 459
	 (:dense (setq dense val))
	 (:inherit (setq inherit val))
460
	 (:suppress (setq suppress val))
461
	 (:group)
462 463 464 465
	 (t (message "Unknown argument %s in defmap" key)))))
    (unless (keymapp m)
      (setq bs (append m bs))
      (setq m (if dense (make-keymap name) (make-sparse-keymap name))))
466 467
    (when suppress
      (suppress-keymap m (eq suppress 'nodigits)))
468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486
    (dolist (b bs)
      (let ((keys (car b))
	    (binding (cdr b)))
	(dolist (key (if (consp keys) keys (list keys)))
	  (cond
	   ((symbolp key)
	    (substitute-key-definition key binding m global-map))
	   ((null binding)
	    (unless (keymapp (lookup-key m key)) (define-key m key binding)))
	   ((let ((o (lookup-key m key)))
	      (or (null o) (numberp o) (eq o 'undefined)))
	    (define-key m key binding))))))
    (cond
     ((keymapp inherit) (set-keymap-parent m inherit))
     ((consp inherit) (easy-mmode-set-keymap-parents m inherit)))
    m))

;;;###autoload
(defmacro easy-mmode-defmap (m bs doc &rest args)
487 488 489
  "Define a constant M whose value is the result of `easy-mmode-define-keymap'.
The M, BS, and ARGS arguments are as per that function.  DOC is
the constant's documentation."
490 491 492
  `(defconst ,m
     (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args))
     ,doc))
493 494 495 496 497 498 499


;;;
;;; easy-mmode-defsyntax
;;;

(defun easy-mmode-define-syntax (css args)
500 501
  (let ((st (make-syntax-table (plist-get args :copy)))
	(parent (plist-get args :inherit)))
502 503 504 505
    (dolist (cs css)
      (let ((char (car cs))
	    (syntax (cdr cs)))
	(if (sequencep char)
506
	    (mapc (lambda (c) (modify-syntax-entry c syntax st)) char)
507
	  (modify-syntax-entry char syntax st))))
508 509
    (if parent (set-char-table-parent
		st (if (symbolp parent) (symbol-value parent) parent)))
510 511 512 513
    st))

;;;###autoload
(defmacro easy-mmode-defsyntax (st css doc &rest args)
514
  "Define variable ST as a syntax-table.
515
CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)."
516 517
  `(progn
     (autoload 'easy-mmode-define-syntax "easy-mmode")
518
     (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc)))
519 520


521 522 523 524 525

;;;
;;; easy-mmode-define-navigation
;;;

526 527
(defmacro easy-mmode-define-navigation (base re &optional name endfun narrowfun
                                             &rest body)
528 529
  "Define BASE-next and BASE-prev to navigate in the buffer.
RE determines the places the commands should move point to.
530
NAME should describe the entities matched by RE.  It is used to build
531 532 533 534
  the docstrings of the two functions.
BASE-next also tries to make sure that the whole entry is visible by
  searching for its end (by calling ENDFUN if provided or by looking for
  the next entry) and recentering if necessary.
535 536
ENDFUN should return the end position (with or without moving point).
NARROWFUN non-nil means to check for narrowing before moving, and if
537 538 539
found, do `widen' first and then call NARROWFUN with no args after moving.
BODY is executed after moving to the destination location."
  (declare (indent 5) (debug (exp exp exp def-form def-form &rest def-body)))
540 541
  (let* ((base-name (symbol-name base))
	 (prev-sym (intern (concat base-name "-prev")))
542
	 (next-sym (intern (concat base-name "-next")))
543 544 545 546 547 548 549 550
         (when-narrowed
          (lambda (body)
            (if (null narrowfun) body
              `(let ((was-narrowed
                      (prog1 (or (< (- (point-max) (point-min)) (buffer-size)))
                        (widen))))
                 ,body
                 (when was-narrowed (,narrowfun)))))))
551
    (unless name (setq name base-name))
552
    `(progn
553 554
       (add-to-list 'debug-ignored-errors
		    ,(concat "^No \\(previous\\|next\\) " (regexp-quote name)))
555
       (defun ,next-sym (&optional count)
556
	 ,(format "Go to the next COUNT'th %s." name)
557
	 (interactive "p")
558 559
	 (unless count (setq count 1))
	 (if (< count 0) (,prev-sym (- count))
560
	   (if (looking-at ,re) (setq count (1+ count)))
561 562 563 564 565 566 567
           ,(funcall when-narrowed
             `(if (not (re-search-forward ,re nil t count))
                  (if (looking-at ,re)
                      (goto-char (or ,(if endfun `(,endfun)) (point-max)))
                    (error "No next %s" ,name))
                (goto-char (match-beginning 0))
                (when (and (eq (current-buffer) (window-buffer (selected-window)))
568
                           (called-interactively-p 'interactive))
569 570 571 572 573 574 575
                  (let ((endpt (or (save-excursion
                                     ,(if endfun `(,endfun)
                                        `(re-search-forward ,re nil t 2)))
                                   (point-max))))
                    (unless (pos-visible-in-window-p endpt nil t)
                      (recenter '(0)))))))
           ,@body))
576
       (put ',next-sym 'definition-name ',base)
577 578
       (defun ,prev-sym (&optional count)
	 ,(format "Go to the previous COUNT'th %s" (or name base-name))
579
	 (interactive "p")
580 581
	 (unless count (setq count 1))
	 (if (< count 0) (,next-sym (- count))
582 583 584 585
           ,(funcall when-narrowed
             `(unless (re-search-backward ,re nil t count)
                (error "No previous %s" ,name)))
           ,@body))
586
       (put ',prev-sym 'definition-name ',base))))
587

588

Richard M. Stallman's avatar
Richard M. Stallman committed
589 590 591
(provide 'easy-mmode)

;;; easy-mmode.el ends here