lisp/emacs-lisp/easy-mmode.el

   1 ;;; easy-mmode.el --- easy definition for major and minor modes
   2
   3 ;; Copyright (C) 1997, 2000-2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr>
   6 ;; Maintainer: Stefan Monnier <monnier@gnu.org>
   7 ;; Package: emacs
   8
   9 ;; Keywords: extensions lisp
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; 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/>.
  25
  26 ;;; Commentary:
  27
  28 ;; Minor modes are useful and common.  This package makes defining a
  29 ;; minor mode easy, by focusing on the writing of the minor mode
  30 ;; functionalities themselves.  Moreover, this package enforces a
  31 ;; conventional naming of user interface primitives, making things
  32 ;; natural for the minor-mode end-users.
  33
  34 ;; For each mode, easy-mmode defines the following:
  35 ;; <mode>      : The minor mode predicate. A buffer-local variable.
  36 ;; <mode>-map  : The keymap possibly associated to <mode>.
  37 ;;       see `define-minor-mode' documentation
  38 ;;
  39 ;; eval
  40 ;;  (pp (macroexpand '(define-minor-mode <your-mode> <doc>)))
  41 ;; to check the result before using it.
  42
  43 ;; The order in which minor modes are installed is important.  Keymap
  44 ;; lookup proceeds down minor-mode-map-alist, and the order there
  45 ;; tends to be the reverse of the order in which the modes were
  46 ;; installed.  Perhaps there should be a feature to let you specify
  47 ;; orderings.
  48
  49 ;; Additionally to `define-minor-mode', the package provides convenient
  50 ;; ways to define keymaps, and other helper functions for major and minor modes.
  51
  52 ;;; Code:
  53
  54 (defun easy-mmode-pretty-mode-name (mode &optional lighter)
  55   "Turn the symbol MODE into a string intended for the user.
  56 If provided, LIGHTER will be used to help choose capitalization by,
  57 replacing its case-insensitive matches with the literal string in LIGHTER."
  58   (let* ((case-fold-search t)
  59          ;; Produce "Foo-Bar minor mode" from foo-bar-minor-mode.
  60          (name (concat (replace-regexp-in-string
  61                         ;; If the original mode name included "-minor" (some
  62                         ;; of them don't, e.g. auto-revert-mode), then
  63                         ;; replace it with " minor".
  64                         "-Minor" " minor"
  65                         ;; "foo-bar-minor" -> "Foo-Bar-Minor"
  66                         (capitalize (replace-regexp-in-string
  67                                      ;; "foo-bar-minor-mode" -> "foo-bar-minor"
  68                                      "toggle-\\|-mode\\'" ""
  69                                      (symbol-name mode))))
  70                        " mode")))
  71     (if (not (stringp lighter)) name
  72       ;; Strip leading and trailing whitespace from LIGHTER.
  73       (setq lighter (replace-regexp-in-string "\\`\\s-+\\|\\s-+\\'" ""
  74                                               lighter))
  75       ;; Replace any (case-insensitive) matches for LIGHTER in NAME
  76       ;; with a literal LIGHTER.  E.g., if NAME is "Iimage mode" and
  77       ;; LIGHTER is " iImag", then this will produce "iImage mode".
  78       ;; (LIGHTER normally comes from the mode-line string passed to
  79       ;; define-minor-mode, and normally includes at least one leading
  80       ;; space.)
  81       (replace-regexp-in-string (regexp-quote lighter) lighter name t t))))
  82
  83 ;;;###autoload
  84 (defalias 'easy-mmode-define-minor-mode 'define-minor-mode)
  85 ;;;###autoload
  86 (defmacro define-minor-mode (mode doc &optional init-value lighter keymap &rest body)
  87   "Define a new minor mode MODE.
  88 This defines the toggle command MODE and (by default) a control variable
  89 MODE (you can override this with the :variable keyword, see below).
  90 DOC is the documentation for the mode toggle command.
  91
  92 The defined mode command takes one optional (prefix) argument.
  93 Interactively with no prefix argument, it toggles the mode.
  94 A prefix argument enables the mode if the argument is positive,
  95 and disables it otherwise.
  96
  97 When called from Lisp, the mode command toggles the mode if the
  98 argument is `toggle', disables the mode if the argument is a
  99 non-positive integer, and enables the mode otherwise (including
 100 if the argument is omitted or nil or a positive integer).
 101
 102 If DOC is nil, give the mode command a basic doc-string
 103 documenting what its argument does.
 104
 105 Optional INIT-VALUE is the initial value of the mode's variable.
 106 Optional LIGHTER is displayed in the mode line when the mode is on.
 107 Optional KEYMAP is the default keymap bound to the mode keymap.
 108   If non-nil, it should be a variable name (whose value is a keymap),
 109   or an expression that returns either a keymap or a list of
 110   arguments for `easy-mmode-define-keymap'.  If you supply a KEYMAP
 111   argument that is not a symbol, this macro defines the variable
 112   MODE-map and gives it the value that KEYMAP specifies.
 113
 114 BODY contains code to execute each time the mode is enabled or disabled.
 115   It is executed after toggling the mode, and before running MODE-hook.
 116   Before the actual body code, you can write keyword arguments, i.e.
 117   alternating keywords and values.  These following special keywords
 118   are supported (other keywords are passed to `defcustom' if the minor
 119   mode is global):
 120
 121 :group GROUP    Custom group name to use in all generated `defcustom' forms.
 122                 Defaults to MODE without the possible trailing \"-mode\".
 123                 Don't use this default group name unless you have written a
 124                 `defgroup' to define that group properly.
 125 :global GLOBAL  If non-nil specifies that the minor mode is not meant to be
 126                 buffer-local, so don't make the variable MODE buffer-local.
 127                 By default, the mode is buffer-local.
 128 :init-value VAL Same as the INIT-VALUE argument.
 129                 Not used if you also specify :variable.
 130 :lighter SPEC   Same as the LIGHTER argument.
 131 :keymap MAP     Same as the KEYMAP argument.
 132 :require SYM    Same as in `defcustom'.
 133 :variable PLACE The location to use instead of the variable MODE to store
 134                 the state of the mode.  This can be simply a different
 135                 named variable, or a generalized variable.
 136                 PLACE can also be of the form \(GET . SET), where GET is
 137                 an expression that returns the current state, and SET is
 138                 a function that takes one argument, the new state, and
 139                 sets it.  If you specify a :variable, this function does
 140                 not define a MODE variable (nor any of the terms used
 141                 in :variable).
 142
 143 :after-hook     A single lisp form which is evaluated after the mode hooks
 144                 have been run.  It should not be quoted.
 145
 146 For example, you could write
 147   (define-minor-mode foo-mode \"If enabled, foo on you!\"
 148     :lighter \" Foo\" :require 'foo :global t :group 'hassle :version \"27.5\"
 149     ...BODY CODE...)"
 150   (declare (doc-string 2)
 151            (debug (&define name stringp
 152                            [&optional [&not keywordp] sexp
 153                             &optional [&not keywordp] sexp
 154                             &optional [&not keywordp] sexp]
 155                            [&rest [keywordp sexp]]
 156                            def-body)))
 157
 158   ;; Allow skipping the first three args.
 159   (cond
 160    ((keywordp init-value)
 161     (setq body `(,init-value ,lighter ,keymap ,@body)
 162           init-value nil lighter nil keymap nil))
 163    ((keywordp lighter)
 164     (setq body `(,lighter ,keymap ,@body) lighter nil keymap nil))
 165    ((keywordp keymap) (push keymap body) (setq keymap nil)))
 166
 167   (let* ((last-message (make-symbol "last-message"))
 168          (mode-name (symbol-name mode))
 169          (pretty-name (easy-mmode-pretty-mode-name mode lighter))
 170          (globalp nil)
 171          (set nil)
 172          (initialize nil)
 173          (group nil)
 174          (type nil)
 175          (extra-args nil)
 176          (extra-keywords nil)
 177          (variable nil)          ;The PLACE where the state is stored.
 178          (setter nil)            ;The function (if any) to set the mode var.
 179          (modefun mode)          ;The minor mode function name we're defining.
 180          (require t)
 181          (after-hook nil)
 182          (hook (intern (concat mode-name "-hook")))
 183          (hook-on (intern (concat mode-name "-on-hook")))
 184          (hook-off (intern (concat mode-name "-off-hook")))
 185          keyw keymap-sym tmp)
 186
 187     ;; Check keys.
 188     (while (keywordp (setq keyw (car body)))
 189       (setq body (cdr body))
 190       (pcase keyw
 191         (`:init-value (setq init-value (pop body)))
 192         (`:lighter (setq lighter (purecopy (pop body))))
 193         (`:global (setq globalp (pop body)))
 194         (`:extra-args (setq extra-args (pop body)))
 195         (`:set (setq set (list :set (pop body))))
 196         (`:initialize (setq initialize (list :initialize (pop body))))
 197         (`:group (setq group (nconc group (list :group (pop body)))))
 198         (`:type (setq type (list :type (pop body))))
 199         (`:require (setq require (pop body)))
 200         (`:keymap (setq keymap (pop body)))
 201         (`:variable (setq variable (pop body))
 202          (if (not (and (setq tmp (cdr-safe variable))
 203                        (or (symbolp tmp)
 204                            (functionp tmp))))
 205              ;; PLACE is not of the form (GET . SET).
 206              (setq mode variable)
 207            (setq mode (car variable))
 208            (setq setter (cdr variable))))
 209         (`:after-hook (setq after-hook (pop body)))
 210         (_ (push keyw extra-keywords) (push (pop body) extra-keywords))))
 211
 212     (setq keymap-sym (if (and keymap (symbolp keymap)) keymap
 213                        (intern (concat mode-name "-map"))))
 214
 215     (unless set (setq set '(:set 'custom-set-minor-mode)))
 216
 217     (unless initialize
 218       (setq initialize '(:initialize 'custom-initialize-default)))
 219
 220     (unless group
 221       ;; We might as well provide a best-guess default group.
 222       (setq group
 223             `(:group ',(intern (replace-regexp-in-string
 224                                 "-mode\\'" "" mode-name)))))
 225
 226     ;; TODO? Mark booleans as safe if booleanp?  Eg abbrev-mode.
 227     (unless type (setq type '(:type 'boolean)))
 228
 229     `(progn
 230        ;; Define the variable to enable or disable the mode.
 231        ,(cond
 232          ;; If :variable is specified, then the var will be
 233          ;; declared elsewhere.
 234          (variable nil)
 235          ((not globalp)
 236           `(progn
 237              :autoload-end
 238              (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled.
 239 Use the command `%s' to change this variable." pretty-name mode))
 240              (make-variable-buffer-local ',mode)))
 241          (t
 242           (let ((base-doc-string
 243                  (concat "Non-nil if %s is enabled.
 244 See the command `%s' for a description of this minor mode."
 245                          (if body "
 246 Setting this variable directly does not take effect;
 247 either customize it (see the info node `Easy Customization')
 248 or call the function `%s'."))))
 249             `(defcustom ,mode ,init-value
 250                ,(format base-doc-string pretty-name mode mode)
 251                ,@set
 252                ,@initialize
 253                ,@group
 254                ,@type
 255                ,@(unless (eq require t) `(:require ,require))
 256                ,@(nreverse extra-keywords)))))
 257
 258        ;; The actual function.
 259        (defun ,modefun (&optional arg ,@extra-args)
 260          ,(or doc
 261               (format (concat "Toggle %s on or off.
 262 With a prefix argument ARG, enable %s if ARG is
 263 positive, and disable it otherwise.  If called from Lisp, enable
 264 the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'.
 265 \\{%s}") pretty-name pretty-name keymap-sym))
 266          ;; Use `toggle' rather than (if ,mode 0 1) so that using
 267          ;; repeat-command still does the toggling correctly.
 268          (interactive (list (or current-prefix-arg 'toggle)))
 269          (let ((,last-message (current-message)))
 270            (,@(if setter `(funcall #',setter)
 271                 (list (if (symbolp mode) 'setq 'setf) mode))
 272             (if (eq arg 'toggle)
 273                 (not ,mode)
 274               ;; A nil argument also means ON now.
 275               (> (prefix-numeric-value arg) 0)))
 276            ,@body
 277            ;; The on/off hooks are here for backward compatibility only.
 278            (run-hooks ',hook (if ,mode ',hook-on ',hook-off))
 279            (if (called-interactively-p 'any)
 280                (progn
 281                  ,(if (and globalp (symbolp mode))
 282                       `(customize-mark-as-set ',mode))
 283                  ;; Avoid overwriting a message shown by the body,
 284                  ;; but do overwrite previous messages.
 285                  (unless (and (current-message)
 286                               (not (equal ,last-message
 287                                           (current-message))))
 288                    (message ,(format "%s %%sabled" pretty-name)
 289                             (if ,mode "en" "dis")))))
 290            ,@(when after-hook `(,after-hook)))
 291          (force-mode-line-update)
 292          ;; Return the new setting.
 293          ,mode)
 294
 295        ;; Autoloading a define-minor-mode autoloads everything
 296        ;; up-to-here.
 297        :autoload-end
 298
 299        ;; Define the minor-mode keymap.
 300        ,(unless (symbolp keymap)        ;nil is also a symbol.
 301           `(defvar ,keymap-sym
 302              (let ((m ,keymap))
 303                (cond ((keymapp m) m)
 304                      ((listp m) (easy-mmode-define-keymap m))
 305                      (t (error "Invalid keymap %S" m))))
 306              ,(format "Keymap for `%s'." mode-name)))
 307
 308        ,(if (not (symbolp mode))
 309             (if (or lighter keymap)
 310                 (error ":lighter and :keymap unsupported with mode expression %s" mode))
 311           `(with-no-warnings
 312              (add-minor-mode ',mode ',lighter
 313                            ,(if keymap keymap-sym
 314                                 `(if (boundp ',keymap-sym) ,keymap-sym))
 315                              nil
 316                              ,(unless (eq mode modefun) `',modefun)))))))
 317 \f
 318 ;;;
 319 ;;; make global minor mode
 320 ;;;
 321
 322 ;;;###autoload
 323 (defalias 'easy-mmode-define-global-mode 'define-globalized-minor-mode)
 324 ;;;###autoload
 325 (defalias 'define-global-minor-mode 'define-globalized-minor-mode)
 326 ;;;###autoload
 327 (defmacro define-globalized-minor-mode (global-mode mode turn-on &rest keys)
 328   "Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE.
 329 TURN-ON is a function that will be called with no args in every buffer
 330   and that should try to turn MODE on if applicable for that buffer.
 331 KEYS is a list of CL-style keyword arguments.  As the minor mode
 332   defined by this function is always global, any :global keyword is
 333   ignored.  Other keywords have the same meaning as in `define-minor-mode',
 334   which see.  In particular, :group specifies the custom group.
 335   The most useful keywords are those that are passed on to the
 336   `defcustom'.  It normally makes no sense to pass the :lighter
 337   or :keymap keywords to `define-globalized-minor-mode', since these
 338   are usually passed to the buffer-local version of the minor mode.
 339
 340 If MODE's set-up depends on the major mode in effect when it was
 341 enabled, then disabling and reenabling MODE should make MODE work
 342 correctly with the current major mode.  This is important to
 343 prevent problems with derived modes, that is, major modes that
 344 call another major mode in their body."
 345   (declare (doc-string 2))
 346   (let* ((global-mode-name (symbol-name global-mode))
 347          (pretty-name (easy-mmode-pretty-mode-name mode))
 348          (pretty-global-name (easy-mmode-pretty-mode-name global-mode))
 349          (group nil)
 350          (extra-keywords nil)
 351          (MODE-buffers (intern (concat global-mode-name "-buffers")))
 352          (MODE-enable-in-buffers
 353           (intern (concat global-mode-name "-enable-in-buffers")))
 354          (MODE-check-buffers
 355           (intern (concat global-mode-name "-check-buffers")))
 356          (MODE-cmhh (intern (concat global-mode-name "-cmhh")))
 357          (MODE-major-mode (intern (concat (symbol-name mode) "-major-mode")))
 358          keyw)
 359
 360     ;; Check keys.
 361     (while (keywordp (setq keyw (car keys)))
 362       (setq keys (cdr keys))
 363       (pcase keyw
 364         (`:group (setq group (nconc group (list :group (pop keys)))))
 365         (`:global (setq keys (cdr keys)))
 366         (_ (push keyw extra-keywords) (push (pop keys) extra-keywords))))
 367
 368     (unless group
 369       ;; We might as well provide a best-guess default group.
 370       (setq group
 371             `(:group ',(intern (replace-regexp-in-string
 372                                 "-mode\\'" "" (symbol-name mode))))))
 373
 374     `(progn
 375        (progn
 376          :autoload-end
 377          (defvar ,MODE-major-mode nil)
 378          (make-variable-buffer-local ',MODE-major-mode))
 379        ;; The actual global minor-mode
 380        (define-minor-mode ,global-mode
 381          ;; Very short lines to avoid too long lines in the generated
 382          ;; doc string.
 383          ,(format "Toggle %s in all buffers.
 384 With prefix ARG, enable %s if ARG is positive;
 385 otherwise, disable it.  If called from Lisp, enable the mode if
 386 ARG is omitted or nil.
 387
 388 %s is enabled in all buffers where
 389 \`%s' would do it.
 390 See `%s' for more information on %s."
 391                   pretty-name pretty-global-name
 392                   pretty-name turn-on mode pretty-name)
 393          :global t ,@group ,@(nreverse extra-keywords)
 394
 395          ;; Setup hook to handle future mode changes and new buffers.
 396          (if ,global-mode
 397              (progn
 398                (add-hook 'after-change-major-mode-hook
 399                          ',MODE-enable-in-buffers)
 400                (add-hook 'change-major-mode-after-body-hook
 401                          ',MODE-enable-in-buffers)
 402                (add-hook 'find-file-hook ',MODE-check-buffers)
 403                (add-hook 'change-major-mode-hook ',MODE-cmhh))
 404            (remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers)
 405            (remove-hook 'change-major-mode-after-body-hook
 406                         ',MODE-enable-in-buffers)
 407            (remove-hook 'find-file-hook ',MODE-check-buffers)
 408            (remove-hook 'change-major-mode-hook ',MODE-cmhh))
 409
 410          ;; Go through existing buffers.
 411          (dolist (buf (buffer-list))
 412            (with-current-buffer buf
 413              (if ,global-mode (,turn-on) (when ,mode (,mode -1))))))
 414
 415        ;; Autoloading define-globalized-minor-mode autoloads everything
 416        ;; up-to-here.
 417        :autoload-end
 418
 419        ;; List of buffers left to process.
 420        (defvar ,MODE-buffers nil)
 421
 422        ;; The function that calls TURN-ON in each buffer.
 423        (defun ,MODE-enable-in-buffers ()
 424          (dolist (buf ,MODE-buffers)
 425            (when (buffer-live-p buf)
 426              (with-current-buffer buf
 427                (unless (eq ,MODE-major-mode major-mode)
 428                  (if ,mode
 429                      (progn
 430                        (,mode -1)
 431                        (,turn-on)
 432                        (setq ,MODE-major-mode major-mode))
 433                    (,turn-on)
 434                    (setq ,MODE-major-mode major-mode)))))))
 435        (put ',MODE-enable-in-buffers 'definition-name ',global-mode)
 436
 437        (defun ,MODE-check-buffers ()
 438          (,MODE-enable-in-buffers)
 439          (setq ,MODE-buffers nil)
 440          (remove-hook 'post-command-hook ',MODE-check-buffers))
 441        (put ',MODE-check-buffers 'definition-name ',global-mode)
 442
 443        ;; The function that catches kill-all-local-variables.
 444        (defun ,MODE-cmhh ()
 445          (add-to-list ',MODE-buffers (current-buffer))
 446          (add-hook 'post-command-hook ',MODE-check-buffers))
 447        (put ',MODE-cmhh 'definition-name ',global-mode))))
 448
 449 ;;;
 450 ;;; easy-mmode-defmap
 451 ;;;
 452
 453 (eval-and-compile
 454   (if (fboundp 'set-keymap-parents)
 455       (defalias 'easy-mmode-set-keymap-parents 'set-keymap-parents)
 456     (defun easy-mmode-set-keymap-parents (m parents)
 457       (set-keymap-parent
 458        m
 459        (cond
 460         ((not (consp parents)) parents)
 461         ((not (cdr parents)) (car parents))
 462         (t (let ((m (copy-keymap (pop parents))))
 463              (easy-mmode-set-keymap-parents m parents)
 464              m)))))))
 465
 466 ;;;###autoload
 467 (defun easy-mmode-define-keymap (bs &optional name m args)
 468   "Return a keymap built from bindings BS.
 469 BS must be a list of (KEY . BINDING) where
 470 KEY and BINDINGS are suitable for `define-key'.
 471 Optional NAME is passed to `make-sparse-keymap'.
 472 Optional map M can be used to modify an existing map.
 473 ARGS is a list of additional keyword arguments.
 474
 475 Valid keywords and arguments are:
 476
 477   :name      Name of the keymap; overrides NAME argument.
 478   :dense     Non-nil for a dense keymap.
 479   :inherit   Parent keymap.
 480   :group     Ignored.
 481   :suppress  Non-nil to call `suppress-keymap' on keymap,
 482              'nodigits to suppress digits as prefix arguments."
 483   (let (inherit dense suppress)
 484     (while args
 485       (let ((key (pop args))
 486             (val (pop args)))
 487         (pcase key
 488          (`:name (setq name val))
 489          (`:dense (setq dense val))
 490          (`:inherit (setq inherit val))
 491          (`:suppress (setq suppress val))
 492          (`:group)
 493          (_ (message "Unknown argument %s in defmap" key)))))
 494     (unless (keymapp m)
 495       (setq bs (append m bs))
 496       (setq m (if dense (make-keymap name) (make-sparse-keymap name))))
 497     (when suppress
 498       (suppress-keymap m (eq suppress 'nodigits)))
 499     (dolist (b bs)
 500       (let ((keys (car b))
 501             (binding (cdr b)))
 502         (dolist (key (if (consp keys) keys (list keys)))
 503           (cond
 504            ((symbolp key)
 505             (substitute-key-definition key binding m global-map))
 506            ((null binding)
 507             (unless (keymapp (lookup-key m key)) (define-key m key binding)))
 508            ((let ((o (lookup-key m key)))
 509               (or (null o) (numberp o) (eq o 'undefined)))
 510             (define-key m key binding))))))
 511     (cond
 512      ((keymapp inherit) (set-keymap-parent m inherit))
 513      ((consp inherit) (easy-mmode-set-keymap-parents m inherit)))
 514     m))
 515
 516 ;;;###autoload
 517 (defmacro easy-mmode-defmap (m bs doc &rest args)
 518   "Define a constant M whose value is the result of `easy-mmode-define-keymap'.
 519 The M, BS, and ARGS arguments are as per that function.  DOC is
 520 the constant's documentation."
 521   `(defconst ,m
 522      (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args))
 523      ,doc))
 524
 525 \f
 526 ;;;
 527 ;;; easy-mmode-defsyntax
 528 ;;;
 529
 530 (defun easy-mmode-define-syntax (css args)
 531   (let ((st (make-syntax-table (plist-get args :copy)))
 532         (parent (plist-get args :inherit)))
 533     (dolist (cs css)
 534       (let ((char (car cs))
 535             (syntax (cdr cs)))
 536         (if (sequencep char)
 537             (mapc (lambda (c) (modify-syntax-entry c syntax st)) char)
 538           (modify-syntax-entry char syntax st))))
 539     (if parent (set-char-table-parent
 540                 st (if (symbolp parent) (symbol-value parent) parent)))
 541     st))
 542
 543 ;;;###autoload
 544 (defmacro easy-mmode-defsyntax (st css doc &rest args)
 545   "Define variable ST as a syntax-table.
 546 CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)."
 547   `(progn
 548      (autoload 'easy-mmode-define-syntax "easy-mmode")
 549      (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc)))
 550
 551
 552 \f
 553 ;;;
 554 ;;; easy-mmode-define-navigation
 555 ;;;
 556
 557 (defmacro easy-mmode-define-navigation (base re &optional name endfun narrowfun
 558                                              &rest body)
 559   "Define BASE-next and BASE-prev to navigate in the buffer.
 560 RE determines the places the commands should move point to.
 561 NAME should describe the entities matched by RE.  It is used to build
 562   the docstrings of the two functions.
 563 BASE-next also tries to make sure that the whole entry is visible by
 564   searching for its end (by calling ENDFUN if provided or by looking for
 565   the next entry) and recentering if necessary.
 566 ENDFUN should return the end position (with or without moving point).
 567 NARROWFUN non-nil means to check for narrowing before moving, and if
 568 found, do `widen' first and then call NARROWFUN with no args after moving.
 569 BODY is executed after moving to the destination location."
 570   (declare (indent 5) (debug (exp exp exp def-form def-form &rest def-body)))
 571   (let* ((base-name (symbol-name base))
 572          (prev-sym (intern (concat base-name "-prev")))
 573          (next-sym (intern (concat base-name "-next")))
 574          (when-narrowed
 575           (lambda (body)
 576             (if (null narrowfun) body
 577               `(let ((was-narrowed
 578                       (prog1 (or (< (- (point-max) (point-min)) (buffer-size)))
 579                         (widen))))
 580                  ,body
 581                  (when was-narrowed (,narrowfun)))))))
 582     (unless name (setq name base-name))
 583     `(progn
 584        (defun ,next-sym (&optional count)
 585          ,(format "Go to the next COUNT'th %s." name)
 586          (interactive "p")
 587          (unless count (setq count 1))
 588          (if (< count 0) (,prev-sym (- count))
 589            (if (looking-at ,re) (setq count (1+ count)))
 590            ,(funcall when-narrowed
 591              `(if (not (re-search-forward ,re nil t count))
 592                   (if (looking-at ,re)
 593                       (goto-char (or ,(if endfun `(,endfun)) (point-max)))
 594                     (user-error "No next %s" ,name))
 595                 (goto-char (match-beginning 0))
 596                 (when (and (eq (current-buffer) (window-buffer (selected-window)))
 597                            (called-interactively-p 'interactive))
 598                   (let ((endpt (or (save-excursion
 599                                      ,(if endfun `(,endfun)
 600                                         `(re-search-forward ,re nil t 2)))
 601                                    (point-max))))
 602                     (unless (pos-visible-in-window-p endpt nil t)
 603                       (recenter '(0)))))))
 604            ,@body))
 605        (put ',next-sym 'definition-name ',base)
 606        (defun ,prev-sym (&optional count)
 607          ,(format "Go to the previous COUNT'th %s" (or name base-name))
 608          (interactive "p")
 609          (unless count (setq count 1))
 610          (if (< count 0) (,next-sym (- count))
 611            ,(funcall when-narrowed
 612              `(unless (re-search-backward ,re nil t count)
 613                 (user-error "No previous %s" ,name)))
 614            ,@body))
 615        (put ',prev-sym 'definition-name ',base))))
 616
 617
 618 (provide 'easy-mmode)
 619
 620 ;;; easy-mmode.el ends here