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