Line data Source code
1 : ;;; derived.el --- allow inheritance of major modes
2 : ;; (formerly mode-clone.el)
3 :
4 : ;; Copyright (C) 1993-1994, 1999, 2001-2017 Free Software Foundation,
5 : ;; Inc.
6 :
7 : ;; Author: David Megginson (dmeggins@aix1.uottawa.ca)
8 : ;; Maintainer: emacs-devel@gnu.org
9 : ;; Keywords: extensions
10 : ;; Package: emacs
11 :
12 : ;; This file is part of GNU Emacs.
13 :
14 : ;; GNU Emacs is free software: you can redistribute it and/or modify
15 : ;; it under the terms of the GNU General Public License as published by
16 : ;; the Free Software Foundation, either version 3 of the License, or
17 : ;; (at your option) any later version.
18 :
19 : ;; GNU Emacs is distributed in the hope that it will be useful,
20 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 : ;; GNU General Public License for more details.
23 :
24 : ;; You should have received a copy of the GNU General Public License
25 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 :
27 : ;;; Commentary:
28 :
29 : ;; GNU Emacs is already, in a sense, object oriented -- each object
30 : ;; (buffer) belongs to a class (major mode), and that class defines
31 : ;; the relationship between messages (input events) and methods
32 : ;; (commands) by means of a keymap.
33 : ;;
34 : ;; The only thing missing is a good scheme of inheritance. It is
35 : ;; possible to simulate a single level of inheritance with generous
36 : ;; use of hooks and a bit of work -- sgml-mode, for example, also runs
37 : ;; the hooks for text-mode, and keymaps can inherit from other keymaps
38 : ;; -- but generally, each major mode ends up reinventing the wheel.
39 : ;; Ideally, someone should redesign all of Emacs's major modes to
40 : ;; follow a more conventional object-oriented system: when defining a
41 : ;; new major mode, the user should need only to name the existing mode
42 : ;; it is most similar to, then list the (few) differences.
43 : ;;
44 : ;; In the mean time, this package offers most of the advantages of
45 : ;; full inheritance with the existing major modes. The macro
46 : ;; `define-derived-mode' allows the user to make a variant of an existing
47 : ;; major mode, with its own keymap. The new mode will inherit the key
48 : ;; bindings of its parent, and will, in fact, run its parent first
49 : ;; every time it is called. For example, the commands
50 : ;;
51 : ;; (define-derived-mode hypertext-mode text-mode "Hypertext"
52 : ;; "Major mode for hypertext.\n\n\\{hypertext-mode-map}"
53 : ;; (setq case-fold-search nil))
54 : ;;
55 : ;; (define-key hypertext-mode-map [down-mouse-3] 'do-hyper-link)
56 : ;;
57 : ;; will create a function `hypertext-mode' with its own (sparse)
58 : ;; keymap `hypertext-mode-map.' The command M-x hypertext-mode will
59 : ;; perform the following actions:
60 : ;;
61 : ;; - run the command (text-mode) to get its default setup
62 : ;; - replace the current keymap with 'hypertext-mode-map,' which will
63 : ;; inherit from 'text-mode-map'.
64 : ;; - replace the current syntax table with
65 : ;; 'hypertext-mode-syntax-table', which will borrow its defaults
66 : ;; from the current text-mode-syntax-table.
67 : ;; - replace the current abbrev table with
68 : ;; 'hypertext-mode-abbrev-table', which will borrow its defaults
69 : ;; from the current text-mode-abbrev table
70 : ;; - change the mode line to read "Hypertext"
71 : ;; - assign the value 'hypertext-mode' to the 'major-mode' variable
72 : ;; - run the body of commands provided in the macro -- in this case,
73 : ;; set the local variable `case-fold-search' to nil.
74 : ;;
75 : ;; The advantages of this system are threefold. First, text mode is
76 : ;; untouched -- if you had added the new keystroke to `text-mode-map,'
77 : ;; possibly using hooks, you would have added it to all text buffers
78 : ;; -- here, it appears only in hypertext buffers, where it makes
79 : ;; sense. Second, it is possible to build even further, and make
80 : ;; a derived mode from a derived mode. The commands
81 : ;;
82 : ;; (define-derived-mode html-mode hypertext-mode "HTML")
83 : ;; [various key definitions]
84 : ;;
85 : ;; will add a new major mode for HTML with very little fuss.
86 : ;;
87 : ;; Note also the function `derived-mode-p' which can tell if the current
88 : ;; mode derives from another. In a hypertext-mode, buffer, for example,
89 : ;; (derived-mode-p 'text-mode) would return non-nil. This should always
90 : ;; be used in place of (eq major-mode 'text-mode).
91 :
92 : ;;; Code:
93 :
94 : ;;; PRIVATE: defsubst must be defined before they are first used
95 :
96 : (defsubst derived-mode-hook-name (mode)
97 : "Construct a mode-hook name based on a MODE name."
98 44 : (intern (concat (symbol-name mode) "-hook")))
99 :
100 : (defsubst derived-mode-map-name (mode)
101 : "Construct a map name based on a MODE name."
102 44 : (intern (concat (symbol-name mode) "-map")))
103 :
104 : (defsubst derived-mode-syntax-table-name (mode)
105 : "Construct a syntax-table name based on a MODE name."
106 22 : (intern (concat (symbol-name mode) "-syntax-table")))
107 :
108 : (defsubst derived-mode-abbrev-table-name (mode)
109 : "Construct an abbrev-table name based on a MODE name."
110 22 : (intern (concat (symbol-name mode) "-abbrev-table")))
111 :
112 : ;; PUBLIC: define a new major mode which inherits from an existing one.
113 :
114 : ;;;###autoload
115 : (defmacro define-derived-mode (child parent name &optional docstring &rest body)
116 : "Create a new mode as a variant of an existing mode.
117 :
118 : The arguments to this command are as follow:
119 :
120 : CHILD: the name of the command for the derived mode.
121 : PARENT: the name of the command for the parent mode (e.g. `text-mode')
122 : or nil if there is no parent.
123 : NAME: a string which will appear in the status line (e.g. \"Hypertext\")
124 : DOCSTRING: an optional documentation string--if you do not supply one,
125 : the function will attempt to invent something useful.
126 : BODY: forms to execute just before running the
127 : hooks for the new mode. Do not use `interactive' here.
128 :
129 : BODY can start with a bunch of keyword arguments. The following keyword
130 : arguments are currently understood:
131 : :group GROUP
132 : Declare the customization group that corresponds to this mode.
133 : The command `customize-mode' uses this.
134 : :syntax-table TABLE
135 : Use TABLE instead of the default (CHILD-syntax-table).
136 : A nil value means to simply use the same syntax-table as the parent.
137 : :abbrev-table TABLE
138 : Use TABLE instead of the default (CHILD-abbrev-table).
139 : A nil value means to simply use the same abbrev-table as the parent.
140 : :after-hook FORM
141 : A single lisp form which is evaluated after the mode hooks have been
142 : run. It should not be quoted.
143 :
144 : Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode:
145 :
146 : (define-derived-mode LaTeX-thesis-mode LaTeX-mode \"LaTeX-Thesis\")
147 :
148 : You could then make new key bindings for `LaTeX-thesis-mode-map'
149 : without changing regular LaTeX mode. In this example, BODY is empty,
150 : and DOCSTRING is generated by default.
151 :
152 : On a more complicated level, the following command uses `sgml-mode' as
153 : the parent, and then sets the variable `case-fold-search' to nil:
154 :
155 : (define-derived-mode article-mode sgml-mode \"Article\"
156 : \"Major mode for editing technical articles.\"
157 : (setq case-fold-search nil))
158 :
159 : Note that if the documentation string had been left out, it would have
160 : been generated automatically, with a reference to the keymap.
161 :
162 : The new mode runs the hook constructed by the function
163 : `derived-mode-hook-name'.
164 :
165 : See Info node `(elisp)Derived Modes' for more details."
166 : (declare (debug (&define name symbolp sexp [&optional stringp]
167 : [&rest keywordp sexp] def-body))
168 : (doc-string 4)
169 : ;; Ask not what
170 : ;;(indent 3)
171 : ;; can do for you, ask what it can do to others. IOW, the
172 : ;; missing of indentation setting here is the indentation
173 : ;; setting and not an oversight.
174 : )
175 :
176 22 : (when (and docstring (not (stringp docstring)))
177 : ;; Some trickiness, since what appears to be the docstring may really be
178 : ;; the first element of the body.
179 6 : (push docstring body)
180 22 : (setq docstring nil))
181 :
182 22 : (when (eq parent 'fundamental-mode) (setq parent nil))
183 :
184 22 : (let ((map (derived-mode-map-name child))
185 22 : (syntax (derived-mode-syntax-table-name child))
186 22 : (abbrev (derived-mode-abbrev-table-name child))
187 : (declare-abbrev t)
188 : (declare-syntax t)
189 22 : (hook (derived-mode-hook-name child))
190 : (group nil)
191 : (after-hook nil))
192 :
193 : ;; Process the keyword args.
194 25 : (while (keywordp (car body))
195 6 : (pcase (pop body)
196 0 : (`:group (setq group (pop body)))
197 4 : (`:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil))
198 2 : (`:syntax-table (setq syntax (pop body)) (setq declare-syntax nil))
199 0 : (`:after-hook (setq after-hook (pop body)))
200 22 : (_ (pop body))))
201 :
202 22 : (setq docstring (derived-mode-make-docstring
203 22 : parent child docstring syntax abbrev))
204 :
205 22 : `(progn
206 22 : (defvar ,hook nil
207 22 : ,(format "Hook run after entering %s mode.
208 : No problems result if this variable is not bound.
209 : `add-hook' automatically binds it. (This is true for all hook variables.)"
210 22 : name))
211 22 : (unless (boundp ',map)
212 22 : (put ',map 'definition-name ',child))
213 22 : (with-no-warnings (defvar ,map (make-sparse-keymap)))
214 22 : (unless (get ',map 'variable-documentation)
215 22 : (put ',map 'variable-documentation
216 22 : (purecopy ,(format "Keymap for `%s'." child))))
217 22 : ,(if declare-syntax
218 21 : `(progn
219 21 : (defvar ,syntax)
220 21 : (unless (boundp ',syntax)
221 21 : (put ',syntax 'definition-name ',child)
222 21 : (defvar ,syntax (make-syntax-table)))
223 21 : (unless (get ',syntax 'variable-documentation)
224 21 : (put ',syntax 'variable-documentation
225 22 : (purecopy ,(format "Syntax table for `%s'." child))))))
226 22 : ,(if declare-abbrev
227 20 : `(progn
228 20 : (defvar ,abbrev)
229 20 : (unless (boundp ',abbrev)
230 20 : (put ',abbrev 'definition-name ',child)
231 20 : (defvar ,abbrev
232 20 : (progn (define-abbrev-table ',abbrev nil) ,abbrev)))
233 20 : (unless (get ',abbrev 'variable-documentation)
234 20 : (put ',abbrev 'variable-documentation
235 22 : (purecopy ,(format "Abbrev table for `%s'." child))))))
236 22 : (put ',child 'derived-mode-parent ',parent)
237 22 : ,(if group `(put ',child 'custom-mode-group ,group))
238 :
239 22 : (defun ,child ()
240 22 : ,docstring
241 : (interactive)
242 : ; Run the parent.
243 : (delay-mode-hooks
244 :
245 22 : (,(or parent 'kill-all-local-variables))
246 : ; Identify the child mode.
247 22 : (setq major-mode (quote ,child))
248 22 : (setq mode-name ,name)
249 : ; Identify special modes.
250 22 : ,(when parent
251 13 : `(progn
252 13 : (if (get (quote ,parent) 'mode-class)
253 13 : (put (quote ,child) 'mode-class
254 13 : (get (quote ,parent) 'mode-class)))
255 : ; Set up maps and tables.
256 13 : (unless (keymap-parent ,map)
257 : ;; It would probably be better to set the keymap's parent
258 : ;; at the toplevel rather than inside the mode function,
259 : ;; but this is not easy for at least the following reasons:
260 : ;; - the parent (and its keymap) may not yet be loaded.
261 : ;; - the parent's keymap name may be called something else
262 : ;; than <parent>-mode-map.
263 13 : (set-keymap-parent ,map (current-local-map)))
264 13 : ,(when declare-syntax
265 12 : `(let ((parent (char-table-parent ,syntax)))
266 : (unless (and parent
267 : (not (eq parent (standard-syntax-table))))
268 13 : (set-char-table-parent ,syntax (syntax-table)))))
269 13 : ,(when declare-abbrev
270 12 : `(unless (or (abbrev-table-get ,abbrev :parents)
271 : ;; This can happen if the major mode defines
272 : ;; the abbrev-table to be its parent's.
273 12 : (eq ,abbrev local-abbrev-table))
274 12 : (abbrev-table-put ,abbrev :parents
275 22 : (list local-abbrev-table))))))
276 22 : (use-local-map ,map)
277 22 : ,(when syntax `(set-syntax-table ,syntax))
278 22 : ,(when abbrev `(setq local-abbrev-table ,abbrev))
279 : ; Splice in the body (if any).
280 22 : ,@body
281 : )
282 : ;; Run the hooks, if any.
283 22 : (run-mode-hooks ',hook)
284 22 : ,@(when after-hook
285 0 : `((if delay-mode-hooks
286 0 : (push ',after-hook delayed-after-hook-forms)
287 22 : ,after-hook)))))))
288 :
289 : ;; PUBLIC: find the ultimate class of a derived mode.
290 :
291 : (defun derived-mode-class (mode)
292 : "Find the class of a major MODE.
293 : A mode's class is the first ancestor which is NOT a derived mode.
294 : Use the `derived-mode-parent' property of the symbol to trace backwards.
295 : Since major-modes might all derive from `fundamental-mode', this function
296 : is not very useful."
297 : (declare (obsolete derived-mode-p "22.1"))
298 0 : (while (get mode 'derived-mode-parent)
299 0 : (setq mode (get mode 'derived-mode-parent)))
300 0 : mode)
301 :
302 :
303 : ;;; PRIVATE
304 :
305 : (defun derived-mode-make-docstring (parent child &optional
306 : docstring syntax abbrev)
307 : "Construct a docstring for a new mode if none is provided."
308 :
309 22 : (let ((map (derived-mode-map-name child))
310 22 : (hook (derived-mode-hook-name child)))
311 :
312 22 : (unless (stringp docstring)
313 : ;; Use a default docstring.
314 3 : (setq docstring
315 3 : (if (null parent)
316 : ;; FIXME filling.
317 1 : (format "Major-mode.\nUses keymap `%s'%s%s." map
318 1 : (if abbrev (format "%s abbrev table `%s'"
319 1 : (if syntax "," " and") abbrev) "")
320 1 : (if syntax (format " and syntax-table `%s'" syntax) ""))
321 2 : (format "Major mode derived from `%s' by `define-derived-mode'.
322 : It inherits all of the parent's attributes, but has its own keymap%s:
323 :
324 : `%s'%s
325 :
326 : which more-or-less shadow%s %s's corresponding table%s."
327 2 : parent
328 2 : (cond ((and abbrev syntax)
329 : ",\nabbrev table and syntax table")
330 0 : (abbrev "\nand abbrev table")
331 0 : (syntax "\nand syntax table")
332 2 : (t ""))
333 2 : map
334 2 : (cond ((and abbrev syntax)
335 2 : (format ", `%s' and `%s'" abbrev syntax))
336 0 : ((or abbrev syntax)
337 0 : (format " and `%s'" (or abbrev syntax)))
338 2 : (t ""))
339 2 : (if (or abbrev syntax) "" "s")
340 2 : parent
341 22 : (if (or abbrev syntax) "s" "")))))
342 :
343 22 : (unless (string-match (regexp-quote (symbol-name hook)) docstring)
344 : ;; Make sure the docstring mentions the mode's hook.
345 17 : (setq docstring
346 17 : (concat docstring
347 17 : (if (null parent)
348 : "\n\nThis mode "
349 10 : (concat
350 : "\n\nIn addition to any hooks its parent mode "
351 10 : (if (string-match (format "[`‘]%s['’]"
352 10 : (regexp-quote
353 10 : (symbol-name parent)))
354 10 : docstring)
355 : nil
356 10 : (format "`%s' " parent))
357 17 : "might have run,\nthis mode "))
358 17 : (format "runs the hook `%s'" hook)
359 22 : ", as the final or penultimate step\nduring initialization.")))
360 :
361 22 : (unless (string-match "\\\\[{[]" docstring)
362 : ;; And don't forget to put the mode's keymap.
363 22 : (setq docstring (concat docstring "\n\n\\{" (symbol-name map) "}")))
364 :
365 22 : docstring))
366 :
367 :
368 : ;;; OBSOLETE
369 : ;; The functions below are only provided for backward compatibility with
370 : ;; code byte-compiled with versions of derived.el prior to Emacs-21.
371 :
372 : (defsubst derived-mode-setup-function-name (mode)
373 : "Construct a setup-function name based on a MODE name."
374 0 : (intern (concat (symbol-name mode) "-setup")))
375 :
376 :
377 : ;; Utility functions for defining a derived mode.
378 :
379 : ;;;###autoload
380 : (defun derived-mode-init-mode-variables (mode)
381 : "Initialize variables for a new MODE.
382 : Right now, if they don't already exist, set up a blank keymap, an
383 : empty syntax table, and an empty abbrev table -- these will be merged
384 : the first time the mode is used."
385 :
386 0 : (if (boundp (derived-mode-map-name mode))
387 : t
388 0 : (eval `(defvar ,(derived-mode-map-name mode)
389 : (make-sparse-keymap)
390 0 : ,(format "Keymap for %s." mode)))
391 0 : (put (derived-mode-map-name mode) 'derived-mode-unmerged t))
392 :
393 0 : (if (boundp (derived-mode-syntax-table-name mode))
394 : t
395 0 : (eval `(defvar ,(derived-mode-syntax-table-name mode)
396 : ;; Make a syntax table which doesn't specify anything
397 : ;; for any char. Valid data will be merged in by
398 : ;; derived-mode-merge-syntax-tables.
399 : (make-char-table 'syntax-table nil)
400 0 : ,(format "Syntax table for %s." mode)))
401 0 : (put (derived-mode-syntax-table-name mode) 'derived-mode-unmerged t))
402 :
403 0 : (if (boundp (derived-mode-abbrev-table-name mode))
404 : t
405 0 : (eval `(defvar ,(derived-mode-abbrev-table-name mode)
406 : (progn
407 : (define-abbrev-table (derived-mode-abbrev-table-name mode) nil)
408 : (make-abbrev-table))
409 0 : ,(format "Abbrev table for %s." mode)))))
410 :
411 : ;; Utility functions for running a derived mode.
412 :
413 : (defun derived-mode-set-keymap (mode)
414 : "Set the keymap of the new MODE, maybe merging with the parent."
415 0 : (let* ((map-name (derived-mode-map-name mode))
416 0 : (new-map (eval map-name))
417 0 : (old-map (current-local-map)))
418 0 : (and old-map
419 0 : (get map-name 'derived-mode-unmerged)
420 0 : (derived-mode-merge-keymaps old-map new-map))
421 0 : (put map-name 'derived-mode-unmerged nil)
422 0 : (use-local-map new-map)))
423 :
424 : (defun derived-mode-set-syntax-table (mode)
425 : "Set the syntax table of the new MODE, maybe merging with the parent."
426 0 : (let* ((table-name (derived-mode-syntax-table-name mode))
427 0 : (old-table (syntax-table))
428 0 : (new-table (eval table-name)))
429 0 : (if (get table-name 'derived-mode-unmerged)
430 0 : (derived-mode-merge-syntax-tables old-table new-table))
431 0 : (put table-name 'derived-mode-unmerged nil)
432 0 : (set-syntax-table new-table)))
433 :
434 : (defun derived-mode-set-abbrev-table (mode)
435 : "Set the abbrev table for MODE if it exists.
436 : Always merge its parent into it, since the merge is non-destructive."
437 0 : (let* ((table-name (derived-mode-abbrev-table-name mode))
438 0 : (old-table local-abbrev-table)
439 0 : (new-table (eval table-name)))
440 0 : (derived-mode-merge-abbrev-tables old-table new-table)
441 0 : (setq local-abbrev-table new-table)))
442 :
443 : (defun derived-mode-run-hooks (mode)
444 : "Run the mode hook for MODE."
445 0 : (let ((hooks-name (derived-mode-hook-name mode)))
446 0 : (if (boundp hooks-name)
447 0 : (run-hooks hooks-name))))
448 :
449 : ;; Functions to merge maps and tables.
450 :
451 : (defun derived-mode-merge-keymaps (old new)
452 : "Merge an OLD keymap into a NEW one.
453 : The old keymap is set to be the last cdr of the new one, so that there will
454 : be automatic inheritance."
455 : ;; ?? Can this just use `set-keymap-parent'?
456 0 : (let ((tail new))
457 : ;; Scan the NEW map for prefix keys.
458 0 : (while (consp tail)
459 0 : (and (consp (car tail))
460 0 : (let* ((key (vector (car (car tail))))
461 0 : (subnew (lookup-key new key))
462 0 : (subold (lookup-key old key)))
463 : ;; If KEY is a prefix key in both OLD and NEW, merge them.
464 0 : (and (keymapp subnew) (keymapp subold)
465 0 : (derived-mode-merge-keymaps subold subnew))))
466 0 : (and (vectorp (car tail))
467 : ;; Search a vector of ASCII char bindings for prefix keys.
468 0 : (let ((i (1- (length (car tail)))))
469 0 : (while (>= i 0)
470 0 : (let* ((key (vector i))
471 0 : (subnew (lookup-key new key))
472 0 : (subold (lookup-key old key)))
473 : ;; If KEY is a prefix key in both OLD and NEW, merge them.
474 0 : (and (keymapp subnew) (keymapp subold)
475 0 : (derived-mode-merge-keymaps subold subnew)))
476 0 : (setq i (1- i)))))
477 0 : (setq tail (cdr tail))))
478 0 : (setcdr (nthcdr (1- (length new)) new) old))
479 :
480 : (defun derived-mode-merge-syntax-tables (old new)
481 : "Merge an OLD syntax table into a NEW one.
482 : Where the new table already has an entry, nothing is copied from the old one."
483 0 : (set-char-table-parent new old))
484 :
485 : ;; Merge an old abbrev table into a new one.
486 : ;; This function requires internal knowledge of how abbrev tables work,
487 : ;; presuming that they are obarrays with the abbrev as the symbol, the expansion
488 : ;; as the value of the symbol, and the hook as the function definition.
489 : (defun derived-mode-merge-abbrev-tables (old new)
490 0 : (if old
491 0 : (mapatoms
492 : (lambda (symbol)
493 0 : (or (intern-soft (symbol-name symbol) new)
494 0 : (define-abbrev new (symbol-name symbol)
495 0 : (symbol-value symbol) (symbol-function symbol))))
496 0 : old)))
497 :
498 : (provide 'derived)
499 :
500 : ;;; derived.el ends here
|