lisp/derived.el

   1 ;;; mode-clone.el (alpha version) -- allow inheritance of major modes.
   2 ;;; $Id: mode-clone.el,v 1.5 1993/12/25 14:02:33 david Exp $
   3
   4 ;; Copyright (C) 1993 Free Software Foundation, Inc.
   5
   6 ;; Author: David Megginson (dmeggins@aix1.uottawa.ca)
   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
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23 \f
  24 ;;; Commentary:
  25
  26 ;; GNU Emacs is already, in a sense, object oriented -- each object
  27 ;; (buffer) belongs to a class (major mode), and that class defines
  28 ;; the relationship between messages (input events) and methods
  29 ;; (commands) by means of a keymap.
  30 ;;
  31 ;; The only thing missing is a good scheme of inheritance.  It is
  32 ;; possible to simulate a single level of inheritance with generous
  33 ;; use of hooks and a bit of work -- sgml-mode, for example, also runs
  34 ;; the hooks for text-mode, and keymaps can inherit from other keymaps
  35 ;; -- but generally, each major mode ends up reinventing the wheel.
  36 ;; Ideally, someone should redesign all of Emacs's major modes to
  37 ;; follow a more conventional object-oriented system: when defining a
  38 ;; new major mode, the user should need only to name the existing mode
  39 ;; it is most similar to, then list the (few) differences.
  40 ;;
  41 ;; In the mean time, this package offers most of the advantages of
  42 ;; full inheritance with the existing major modes.  The function
  43 ;; `mode-clone' allows the user to make a clone of an existing
  44 ;; major mode, with its own keymap.  The new mode will inherit the key
  45 ;; bindings of its parent, and will, in fact, run its parent first
  46 ;; every time it is called.  For example, the commands
  47 ;;
  48 ;;  (mode-clone text-mode hypertext-mode "Hypertext"
  49 ;;    "Major mode for hypertext.\n\n\\{hypertext-mode-map}"
  50 ;;    (setq case-fold-search nil))
  51 ;;
  52 ;;  (define-key hypertext-mode-map [down-mouse-3] 'do-hyper-link)
  53 ;;
  54 ;; will create a function `hypertext-mode' with its own (sparse)
  55 ;; keymap `hypertext-mode-map.'  The command M-x hypertext-mode will
  56 ;; perform the following actions:
  57 ;;
  58 ;; - run the command (text-mode) to get its default setup
  59 ;; - replace the current keymap with 'hypertext-mode-map,' which will
  60 ;;   inherit from 'text-mode-map'.
  61 ;; - replace the current syntax table with
  62 ;;   'hypertext-mode-syntax-table', which will borrow its defaults
  63 ;;   from the current text-mode-syntax-table.
  64 ;; - if 'hypertext-mode-abbrev-table' exists, it will become the
  65 ;;   current abbrev table.
  66 ;; - change the mode line to read "Hypertext"
  67 ;; - assign the value 'hypertext-mode' to the 'major-mode' variable
  68 ;; - run the body of commands provided in the macro -- in this case,
  69 ;;   set the local variable `case-fold-search' to nil.
  70 ;; - **run the command (hypertext-mode-setup), which is empty by
  71 ;;   default, but may be redefined by the user to contain special
  72 ;;   commands (ie. setting local variables like 'outline-regexp')
  73 ;;   **NOTE: do not use this option -- it will soon be obsolete.
  74 ;; - run anything assigned to 'hypertext-mode-hooks' (obsolete, but
  75 ;;   supported for the sake of compatibility).
  76 ;;
  77 ;; The advantages of this system are threefold.  First, text mode is
  78 ;; untouched -- if you had added the new keystroke to `text-mode-map,'
  79 ;; possibly using hooks, you would have added it to all text buffers
  80 ;; -- here, it appears only in hypertext buffers, where it makes
  81 ;; sense.  Second, it is possible to build even further, and clone the
  82 ;; clone.  The commands
  83 ;;
  84 ;;   (mode-clone hypertext-mode html-mode "HTML")
  85 ;;   [various key definitions]
  86 ;;
  87 ;; will add a new major mode for HTML with very little fuss.
  88 ;;
  89 ;; Note also the function `clone-class,' which returns the non-clone
  90 ;; major mode which a clone is based on (ie. NOT necessarily the
  91 ;; immediate parent).
  92 ;;
  93 ;; (clone-class 'text-mode) ==> text-mode
  94 ;; (clone-class 'hypertext-mode) ==> text-mode
  95 ;; (clone-class 'html-mode) ==> text-mode
  96 \f
  97 ;;; Code:
  98
  99 ;; PUBLIC: define a new major mode which inherits from an existing one.
 100
 101 ;;;###autoload
 102 (defmacro mode-clone (parent child name &optional docstring &rest body)
 103   "Create a new mode which is similar to an old one.
 104
 105 The arguments to this command are as follow:
 106
 107 parent:    the name of the command for the parent mode (ie. text-mode)
 108 child:     the name of the command for the clone
 109 name:      a string which will appear in the status line (ie. \"Hypertext\")
 110 docstring: an optional documentation string -- if you do not supply one,
 111            the function will attempt to invent something useful.  If this
 112            argument is not a string, it will be added to body automatically.
 113 body:      a body of commands to execute just before running the
 114            hooks for the new mode.
 115
 116 The following simple command would clone LaTeX-mode into
 117 LaTeX-thesis-mode:
 118
 119   (mode-clone LaTeX-mode LaTeX-thesis-mode \"LaTeX-Thesis\")
 120
 121 It would then be possible to assign commands to keystrokes in
 122 `LaTeX-thesis-mode-map' without changing the interface in the regular
 123 LaTeX-mode.  The function (LaTeX-thesis-mode-setup), if it exists,
 124 will contain commands which will run whenever (LaTeX-thesis-mode) is
 125 run (just before 'LaTeX-thesis-mode-hooks).
 126
 127 On a more complicated level, the following command would clone
 128 sgml-mode and change the variable `case-fold-search' to nil:
 129
 130   (mode-clone sgml-mode article-mode \"Article\"
 131     \"Major mode for editing technical articles.\"
 132     (setq case-fold-search nil))
 133
 134 Note that if the documentation string had been left out, it would have
 135 been generated automatically, with a reference to the keymap."
 136
 137                                         ; Some trickiness, since what
 138                                         ; appears to be the docstring
 139                                         ; may really be the first
 140                                         ; element of the body.
 141   (if (and docstring (not (stringp docstring)))
 142       (progn (setq body (cons docstring body))
 143              (setq docstring nil)))
 144   (setq docstring (or docstring (clone-make-docstring parent child)))
 145
 146   (` (progn
 147        (clone-init-mode-variables (quote (, child)))
 148        (defun (, child) ()
 149          (, docstring)
 150          (interactive)
 151                                         ; Run the parent.
 152          ((, parent))
 153                                         ; Identify special modes.
 154          (if (get (quote (, parent)) 'special)
 155              (put (quote (, child)) 'special t))
 156                                         ; Identify the child mode.
 157          (setq major-mode (quote (, child)))
 158          (setq mode-name (, name))
 159                                         ; Set up maps and tables.
 160          (clone-set-keymap (quote (, child)))
 161          (clone-set-syntax-table (quote (, child)))
 162          (clone-set-abbrev-table (quote (, child)))
 163                                         ; Splice in the body (if any).
 164          (,@ body)
 165                                         ; Run the setup function, if
 166                                         ; any -- this will soon be
 167                                         ; obsolete.
 168          (clone-run-setup-function (quote (, child)))
 169                                         ; Run the hooks, if any.
 170          (clone-run-hooks (quote (, child)))))))
 171
 172
 173 ;; PUBLIC: find the ultimate class of a clone mode.
 174
 175 (defun clone-class (mode)
 176   "Find the class of a major mode.
 177 A mode's class is the first ancestor which is NOT a clone.
 178 Use the `clone-parent' property of the symbol to trace backwards."
 179   (while (get mode 'clone-parent)
 180     (setq mode (get mode 'clone-parent)))
 181   mode)
 182
 183 \f
 184 ;; Inline functions to construct various names from a mode name.
 185
 186 (defsubst clone-setup-function-name (mode)
 187   "Construct a setup-function name based on a mode name."
 188   (intern (concat (symbol-name mode) "-setup")))
 189
 190 (defsubst clone-hooks-name (mode)
 191   "Construct a hooks name based on a mode name."
 192   (intern (concat (symbol-name mode) "-hooks")))
 193
 194 (defsubst clone-map-name (mode)
 195   "Construct a map name based on a mode name."
 196   (intern (concat (symbol-name mode) "-map")))
 197
 198 (defsubst clone-syntax-table-name (mode)
 199   "Construct a syntax-table name based on a mode name."
 200   (intern (concat (symbol-name mode) "-syntax-table")))
 201
 202 (defsubst clone-abbrev-table-name (mode)
 203   "Construct an abbrev-table name based on a mode name."
 204   (intern (concat (symbol-name mode) "-abbrev-table")))
 205
 206 \f
 207 ;; Utility functions for defining a clone mode.
 208
 209 (defun clone-init-mode-variables (mode)
 210   "Initialise variables for a new mode.
 211 Right now, just set up a blank keymap and an empty syntax table."
 212
 213   (eval (` (defvar (, (clone-map-name mode))
 214              (make-sparse-keymap)
 215              (, (format "Keymap for %s." mode)))))
 216   (put (clone-map-name mode) 'clone-merged nil)
 217
 218   (eval (` (defvar (, (clone-syntax-table-name mode))
 219              (make-vector 256 nil)
 220              (, (format "Syntax table for %s." mode)))))
 221   (put (clone-syntax-table-name mode) 'clone-merged nil)
 222
 223   (eval (` (defvar (, (clone-abbrev-table-name mode))
 224              nil
 225              (, (format "Abbrev table for %s." mode)))))
 226   (define-abbrev-table (clone-abbrev-table-name mode) ()))
 227
 228 (defun clone-make-docstring (parent child)
 229   "Construct a docstring for a new mode if none is provided."
 230
 231   (format "This major mode is a clone of (%s), created by (mode-clone).
 232 It inherits all of the parent's attributes, but has its own keymap
 233 and syntax table:
 234
 235   '%s-map' and '%s-syntax-table'
 236
 237 which more-or-less shadow
 238
 239   '%s-map' and '%s-syntax-table'
 240
 241 \\{%s-map}" parent child child parent parent child))
 242
 243 \f
 244 ;; Utility functions for running a clone mode.
 245
 246 (defun clone-set-keymap (mode)
 247   "Set the keymap of the new mode, maybe merging with the parent."
 248   (let* ((map-name (clone-map-name mode))
 249          (new-map (eval map-name))
 250          (old-map (current-local-map)))
 251     (if (get map-name 'clone-merged)
 252         (use-local-map new-map)
 253       (put map-name 'clone-merged t)
 254       (use-local-map (set map-name (clone-merge-keymaps old-map new-map))))))
 255
 256 (defun clone-set-syntax-table (mode)
 257   "Set the syntax table of the new mode, maybe merging with the parent."
 258   (let* ((table-name (clone-syntax-table-name mode))
 259          (old-table (syntax-table))
 260          (new-table (eval table-name)))
 261     (if (get table-name 'clone-merged)
 262         t
 263       (clone-merge-syntax-tables old-table new-table))
 264     (set-syntax-table new-table)
 265     (put table-name 'clone-merged t)))
 266
 267 (defun clone-set-abbrev-table (mode)
 268   "Set the abbrev table if it exists."
 269   (let* ((table-name (clone-abbrev-table-name mode))
 270          (table (and (boundp table-name) (eval table-name))))
 271     (if table
 272         (setq local-abbrev-table table))))
 273
 274 (defun clone-run-setup-function (mode)
 275   "Run the setup function if it exists."
 276
 277   (let ((fname (clone-setup-function-name mode)))
 278     (if (fboundp fname)
 279         (funcall fname))))
 280
 281 (defun clone-run-hooks (mode)
 282   "Run the hooks if they exist."
 283
 284   (let ((hooks-name (clone-hooks-name mode)))
 285     (if (boundp hooks-name)
 286         (run-hooks hooks-name))))
 287
 288 ;; Functions to merge maps and tables.
 289
 290 (defun clone-merge-keymaps (old new)
 291   "Merge a new keymap into an old one.
 292 The old keymap is set to be the cdr of the new one, so that there will
 293 be automatic inheritance."
 294   (append new old))
 295
 296 (defun clone-merge-syntax-tables (old new)
 297   "Merge a new syntax table into an old one.
 298 Where the new table already has an entry, nothing is copied from the old one."
 299   (let ((idx 0)
 300         (end (min (length new) (length old))))
 301     (while (< idx end)
 302       (if (not (aref new idx))
 303           (aset new idx (aref old idx)))
 304       (setq idx (1+ idx)))))
 305
 306 (provide 'mode-clone)
 307
 308 ;;; mode-clone.el ends here