lisp/emacs-lisp/easy-mmode.el

   1 ;;; easy-mmode.el --- easy definition for major and minor modes
   2
   3 ;; Copyright (C) 1997,2000  Free Software Foundation, Inc.
   4
   5 ;; Author:  Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr>
   6 ;; Maintainer:  Stefan Monnier <monnier@gnu.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs 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 ;; GNU Emacs 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., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Minor modes are useful and common.  This package makes defining a
  28 ;; minor mode easy, by focusing on the writing of the minor mode
  29 ;; functionalities themselves.  Moreover, this package enforces a
  30 ;; conventional naming of user interface primitives, making things
  31 ;; natural for the minor-mode end-users.
  32
  33 ;; For each mode, easy-mmode defines the following:
  34 ;; <mode>      : The minor mode predicate. A buffer-local variable.
  35 ;; <mode>-map  : The keymap possibly associated to <mode>.
  36 ;; <mode>-hook : The hook run at the end of the toggle function.
  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 (eval-when-compile (require 'cl))
  55
  56 (defun easy-mmode-pretty-mode-name (mode &optional lighter)
  57   "Turn the symbol MODE into a string intended for the user.
  58 If provided LIGHTER will be used to help choose capitalization."
  59   (let* ((case-fold-search t)
  60          (name (concat (replace-regexp-in-string
  61                         "-Minor" " minor"
  62                         (capitalize (replace-regexp-in-string
  63                                      "-mode\\'" "" (symbol-name mode))))
  64                        " mode")))
  65     (if (not (stringp lighter)) name
  66       (setq lighter (replace-regexp-in-string "\\`\\s-+\\|\\-s+\\'" "" lighter))
  67       (replace-regexp-in-string lighter lighter name t t))))
  68
  69 ;;;###autoload
  70 (defalias 'easy-mmode-define-minor-mode 'define-minor-mode)
  71 ;;;###autoload
  72 (defmacro define-minor-mode (mode doc &optional init-value lighter keymap &rest body)
  73   "Define a new minor mode MODE.
  74 This function defines the associated control variable MODE, keymap MODE-map,
  75 toggle command MODE, and hook MODE-hook.
  76
  77 DOC is the documentation for the mode toggle command.
  78 Optional INIT-VALUE is the initial value of the mode's variable.
  79 Optional LIGHTER is displayed in the modeline when the mode is on.
  80 Optional KEYMAP is the default (defvar) keymap bound to the mode keymap.
  81   If it is a list, it is passed to `easy-mmode-define-keymap'
  82   in order to build a valid keymap.  It's generally better to use
  83   a separate MODE-map variable than to use this argument.
  84 The above three arguments can be skipped if keyword arguments are
  85 used (see below).
  86
  87 BODY contains code that will be executed each time the mode is (dis)activated.
  88   It will be executed after any toggling but before running the hooks.
  89   BODY can start with a list of CL-style keys specifying additional arguments.
  90   The following keyword arguments are supported:
  91 :group   Followed by the group name to use for any generated `defcustom'.
  92 :global  If non-nil specifies that the minor mode is not meant to be
  93          buffer-local.  By default, the variable is made buffer-local.
  94 :init-value  Same as the INIT-VALUE argument.
  95 :lighter  Same as the LIGHTER argument."
  96   ;; Allow skipping the first three args.
  97   (cond
  98    ((keywordp init-value)
  99     (setq body (list* init-value lighter keymap body)
 100           init-value nil lighter nil keymap nil))
 101    ((keywordp lighter)
 102     (setq body (list* lighter keymap body) lighter nil keymap nil))
 103    ((keywordp keymap) (push keymap body) (setq keymap nil)))
 104
 105   (let* ((mode-name (symbol-name mode))
 106          (pretty-name (easy-mmode-pretty-mode-name mode lighter))
 107          (globalp nil)
 108          (togglep t)                    ;why would you ever want to toggle?
 109          (group nil)
 110          (extra-args nil)
 111          (keymap-sym (if (and keymap (symbolp keymap)) keymap
 112                        (intern (concat mode-name "-map"))))
 113          (hook (intern (concat mode-name "-hook")))
 114          (hook-on (intern (concat mode-name "-on-hook")))
 115          (hook-off (intern (concat mode-name "-off-hook"))))
 116
 117     ;; Check keys.
 118     (while (keywordp (car body))
 119       (case (pop body)
 120         (:init-value (setq init-value (pop body)))
 121         (:lighter (setq lighter (pop body)))
 122         (:global (setq globalp (pop body)))
 123         (:extra-args (setq extra-args (pop body)))
 124         (:group (setq group (nconc group (list :group (pop body)))))
 125         (t (pop body))))
 126
 127     (unless group
 128       ;; We might as well provide a best-guess default group.
 129       (setq group
 130             `(:group ',(intern (replace-regexp-in-string "-mode\\'" ""
 131                                                          mode-name)))))
 132     ;; Add default properties to LIGHTER.
 133     (unless (or (not (stringp lighter)) (get-text-property 0 'local-map lighter)
 134                 (get-text-property 0 'keymap lighter))
 135       (setq lighter
 136             (apply 'propertize lighter
 137                    'local-map (make-mode-line-mouse2-map mode)
 138                    (unless (get-text-property 0 'help-echo lighter)
 139                      (list 'help-echo
 140                            (format "mouse-2: turn off %s" pretty-name))))))
 141
 142     `(progn
 143        ;; Define the variable to enable or disable the mode.
 144        ,(if (not globalp)
 145             `(progn
 146                (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled.
 147 Use the command `%s' to change this variable." pretty-name mode))
 148                (make-variable-buffer-local ',mode))
 149
 150           (let ((curfile (or (and (boundp 'byte-compile-current-file)
 151                                   byte-compile-current-file)
 152                              load-file-name)))
 153             `(defcustom ,mode ,init-value
 154                ,(format "Non-nil if %s is enabled.
 155 See the command `%s' for a description of this minor-mode.
 156 Setting this variable directly does not take effect;
 157 use either \\[customize] or the function `%s'."
 158                         pretty-name mode mode)
 159                :set (lambda (symbol value) (funcall symbol (or value 0)))
 160                :initialize 'custom-initialize-default
 161                ,@group
 162                :type 'boolean
 163                ,@(when curfile
 164                    (list
 165                     :require
 166                     (list 'quote
 167                           (intern (file-name-nondirectory
 168                                    (file-name-sans-extension curfile)))))))))
 169
 170        ;; The actual function.
 171        (defun ,mode (&optional arg ,@extra-args)
 172          ,(or doc
 173               (format (concat "Toggle %s on or off.
 174 Interactively, with no prefix argument, toggle the mode.
 175 With universal prefix ARG " (unless togglep "(or if ARG is nil) ") "turn mode on.
 176 With zero or negative ARG turn mode off.
 177 \\{%s}") pretty-name keymap-sym))
 178          (interactive (list (or current-prefix-arg (if ,mode 0 1))))
 179          (setq ,mode
 180                (if arg
 181                    (> (prefix-numeric-value arg) 0)
 182                  ,(if togglep `(not ,mode) t)))
 183          ,@body
 184          ;; The on/off hooks are here for backward compatibility only.
 185          (run-hooks ',hook (if ,mode ',hook-on ',hook-off))
 186          ;; Return the new setting.
 187          (if (interactive-p)
 188              (message ,(format "%s %%sabled" pretty-name)
 189                       (if ,mode "en" "dis")))
 190          (force-mode-line-update)
 191          ,mode)
 192
 193        ;; Autoloading an easy-mmode-define-minor-mode autoloads
 194        ;; everything up-to-here.
 195        :autoload-end
 196
 197        ;; The toggle's hook.
 198        (defcustom ,hook nil
 199          ,(format "Hook run at the end of function `%s'." mode-name)
 200          :group ,(cadr group)
 201          :type 'hook)
 202
 203        ;; Define the minor-mode keymap.
 204        ,(unless (symbolp keymap)        ;nil is also a symbol.
 205           `(defvar ,keymap-sym
 206              (let ((m ,keymap))
 207                (cond ((keymapp m) m)
 208                      ((listp m) (easy-mmode-define-keymap m))
 209                      (t (error "Invalid keymap %S" ,keymap))))
 210              ,(format "Keymap for `%s'." mode-name)))
 211
 212        (add-minor-mode ',mode ',lighter
 213                        ,(if keymap keymap-sym
 214                           `(if (boundp ',keymap-sym)
 215                                (symbol-value ',keymap-sym))))
 216
 217        ;; If the mode is global, call the function according to the default.
 218        ,(if globalp
 219             `(if (and load-file-name ,mode)
 220                  (eval-after-load load-file-name '(,mode 1)))))))
 221 \f
 222 ;;;
 223 ;;; make global minor mode
 224 ;;;
 225
 226 ;;;###autoload
 227 (defmacro easy-mmode-define-global-mode (global-mode mode turn-on
 228                                                      &rest keys)
 229   "Make GLOBAL-MODE out of the buffer-local minor MODE.
 230 TURN-ON is a function that will be called with no args in every buffer
 231   and that should try to turn MODE on if applicable for that buffer.
 232 KEYS is a list of CL-style keyword arguments:
 233 :group to specify the custom group."
 234   (let* ((global-mode-name (symbol-name global-mode))
 235          (pretty-name (easy-mmode-pretty-mode-name mode))
 236          (pretty-global-name (easy-mmode-pretty-mode-name global-mode))
 237          (group nil)
 238          (extra-args nil)
 239          (buffers (intern (concat global-mode-name "-buffers")))
 240          (cmmh (intern (concat global-mode-name "-cmmh"))))
 241
 242     ;; Check keys.
 243     (while (keywordp (car keys))
 244       (case (pop keys)
 245         (:extra-args (setq extra-args (pop keys)))
 246         (:group (setq group (nconc group (list :group (pop keys)))))
 247         (t (setq keys (cdr keys)))))
 248
 249     (unless group
 250       ;; We might as well provide a best-guess default group.
 251       (setq group
 252             `(:group ',(intern (replace-regexp-in-string "-mode\\'" ""
 253                                                          (symbol-name mode))))))
 254     `(progn
 255        ;; The actual global minor-mode
 256        (define-minor-mode ,global-mode
 257          ,(format "Toggle %s in every buffer.
 258 With prefix ARG, turn %s on if and only if ARG is positive.
 259 %s is actually not turned on in every buffer but only in those
 260 in which `%s' turns it on."
 261                   pretty-name pretty-global-name pretty-name turn-on)
 262          :global t :extra-args ,extra-args ,@group
 263
 264          ;; Setup hook to handle future mode changes and new buffers.
 265          (if ,global-mode
 266              (progn
 267                (add-hook 'find-file-hooks ',buffers)
 268                (add-hook 'change-major-mode-hook ',cmmh))
 269            (remove-hook 'find-file-hooks ',buffers)
 270            (remove-hook 'change-major-mode-hook ',cmmh))
 271
 272          ;; Go through existing buffers.
 273          (dolist (buf (buffer-list))
 274            (with-current-buffer buf
 275              (if ,global-mode (,turn-on) (when ,mode (,mode -1))))))
 276
 277        ;; Autoloading easy-mmode-define-global-mode
 278        ;; autoloads everything up-to-here.
 279        :autoload-end
 280
 281        ;; List of buffers left to process.
 282        (defvar ,buffers nil)
 283
 284        ;; The function that calls TURN-ON in each buffer.
 285        (defun ,buffers ()
 286          (remove-hook 'post-command-hook ',buffers)
 287          (while ,buffers
 288            (let ((buf (pop ,buffers)))
 289              (when (buffer-live-p buf)
 290                (with-current-buffer buf (,turn-on))))))
 291
 292        ;; The function that catches kill-all-local-variables.
 293        (defun ,cmmh ()
 294          (add-to-list ',buffers (current-buffer))
 295          (add-hook 'post-command-hook ',buffers)))))
 296
 297 ;;;
 298 ;;; easy-mmode-defmap
 299 ;;;
 300
 301 (if (fboundp 'set-keymap-parents)
 302     (defalias 'easy-mmode-set-keymap-parents 'set-keymap-parents)
 303   (defun easy-mmode-set-keymap-parents (m parents)
 304     (set-keymap-parent
 305      m
 306      (cond
 307       ((not (consp parents)) parents)
 308       ((not (cdr parents)) (car parents))
 309       (t (let ((m (copy-keymap (pop parents))))
 310            (easy-mmode-set-keymap-parents m parents)
 311            m))))))
 312
 313 ;;;###autoload
 314 (defun easy-mmode-define-keymap (bs &optional name m args)
 315   "Return a keymap built from bindings BS.
 316 BS must be a list of (KEY . BINDING) where
 317 KEY and BINDINGS are suitable for `define-key'.
 318 Optional NAME is passed to `make-sparse-keymap'.
 319 Optional map M can be used to modify an existing map.
 320 ARGS is a list of additional keyword arguments."
 321   (let (inherit dense suppress)
 322     (while args
 323       (let ((key (pop args))
 324             (val (pop args)))
 325         (case key
 326          (:name (setq name val))
 327          (:dense (setq dense val))
 328          (:inherit (setq inherit val))
 329          (:group)
 330          ;;((eq key :suppress) (setq suppress val))
 331          (t (message "Unknown argument %s in defmap" key)))))
 332     (unless (keymapp m)
 333       (setq bs (append m bs))
 334       (setq m (if dense (make-keymap name) (make-sparse-keymap name))))
 335     (dolist (b bs)
 336       (let ((keys (car b))
 337             (binding (cdr b)))
 338         (dolist (key (if (consp keys) keys (list keys)))
 339           (cond
 340            ((symbolp key)
 341             (substitute-key-definition key binding m global-map))
 342            ((null binding)
 343             (unless (keymapp (lookup-key m key)) (define-key m key binding)))
 344            ((let ((o (lookup-key m key)))
 345               (or (null o) (numberp o) (eq o 'undefined)))
 346             (define-key m key binding))))))
 347     (cond
 348      ((keymapp inherit) (set-keymap-parent m inherit))
 349      ((consp inherit) (easy-mmode-set-keymap-parents m inherit)))
 350     m))
 351
 352 ;;;###autoload
 353 (defmacro easy-mmode-defmap (m bs doc &rest args)
 354   `(defconst ,m
 355      (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args))
 356      ,doc))
 357
 358 \f
 359 ;;;
 360 ;;; easy-mmode-defsyntax
 361 ;;;
 362
 363 (defun easy-mmode-define-syntax (css args)
 364   (let ((st (make-syntax-table (plist-get args :copy)))
 365         (parent (plist-get args :inherit)))
 366     (dolist (cs css)
 367       (let ((char (car cs))
 368             (syntax (cdr cs)))
 369         (if (sequencep char)
 370             (mapcar (lambda (c) (modify-syntax-entry c syntax st)) char)
 371           (modify-syntax-entry char syntax st))))
 372     (if parent (set-char-table-parent
 373                 st (if (symbolp parent) (symbol-value parent) parent)))
 374     st))
 375
 376 ;;;###autoload
 377 (defmacro easy-mmode-defsyntax (st css doc &rest args)
 378   "Define variable ST as a syntax-table.
 379 CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)."
 380   `(progn
 381      (autoload 'easy-mmode-define-syntax "easy-mmode")
 382      (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc)))
 383
 384
 385 \f
 386 ;;;
 387 ;;; easy-mmode-define-navigation
 388 ;;;
 389
 390 (defmacro easy-mmode-define-navigation (base re &optional name endfun)
 391   "Define BASE-next and BASE-prev to navigate in the buffer.
 392 RE determines the places the commands should move point to.
 393 NAME should describe the entities matched by RE.  It is used to build
 394   the docstrings of the two functions.
 395 BASE-next also tries to make sure that the whole entry is visible by
 396   searching for its end (by calling ENDFUN if provided or by looking for
 397   the next entry) and recentering if necessary.
 398 ENDFUN should return the end position (with or without moving point)."
 399   (let* ((base-name (symbol-name base))
 400          (prev-sym (intern (concat base-name "-prev")))
 401          (next-sym (intern (concat base-name "-next"))))
 402     (unless name (setq name (symbol-name base-name)))
 403     `(progn
 404        (add-to-list 'debug-ignored-errors
 405                     ,(concat "^No \\(previous\\|next\\) " (regexp-quote name)))
 406        (defun ,next-sym (&optional count)
 407          ,(format "Go to the next COUNT'th %s." name)
 408          (interactive)
 409          (unless count (setq count 1))
 410          (if (< count 0) (,prev-sym (- count))
 411            (if (looking-at ,re) (incf count))
 412            (if (not (re-search-forward ,re nil t count))
 413                (if (looking-at ,re)
 414                    (goto-char (or ,(if endfun `(,endfun)) (point-max)))
 415                  (error ,(format "No next %s" name)))
 416              (goto-char (match-beginning 0))
 417              (when (and (eq (current-buffer) (window-buffer (selected-window)))
 418                         (interactive-p))
 419                (let ((endpt (or (save-excursion
 420                                   ,(if endfun `(,endfun)
 421                                      `(re-search-forward ,re nil t 2)))
 422                                 (point-max))))
 423                  (unless (pos-visible-in-window-p endpt nil t)
 424                    (recenter '(0))))))))
 425        (defun ,prev-sym (&optional count)
 426          ,(format "Go to the previous COUNT'th %s" (or name base-name))
 427          (interactive)
 428          (unless count (setq count 1))
 429          (if (< count 0) (,next-sym (- count))
 430            (unless (re-search-backward ,re nil t count)
 431              (error ,(format "No previous %s" name))))))))
 432
 433 (provide 'easy-mmode)
 434
 435 ;;; easy-mmode.el ends here