(easy-mmode-define-keymap): Extend to allow more flexibility.

(easy-mmode-set-keymap-parents, easy-mmode-define-syntax): New functions.
(easy-mmode-defmap, easy-mmode-defsyntax, easy-mmode-define-derived-mode):
New macros.

2 files changed, 187 insertions, 14 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 6512731114f..36a12c6c28f 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,11 @@
+2000-03-09  Stefan Monnier  <monnier@cs.yale.edu>
+
+        * emacs-lisp/easy-mmode.el (easy-mmode-define-keymap): Extend to allow
+        more flexibility.
+        (easy-mmode-set-keymap-parents, easy-mmode-define-syntax): New functions.
+        (easy-mmode-defmap, easy-mmode-defsyntax, easy-mmode-define-derived-mode):
+        New macros.
+
 2000-09-01  Didier Verna  <didier@xemacs.org>
 
         * rect.el (replace-rectangle): New function.
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index c39e6b96424..98ee96bdac9 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -1,4 +1,4 @@
-;;; easy-mmode.el --- easy definition of minor modes.
+;;; easy-mmode.el --- easy definition for major and minor modes.
 
 ;; Copyright (C) 1997  Free Software Foundation, Inc.
 
@@ -46,20 +46,10 @@
 ;; installed.  Perhaps there should be a feature to let you specify
 ;; orderings.
 
-;;; Code:
+;; Additionally to `define-minor-mode', the package provides convenient
+;; ways to define keymaps, and other helper functions for major and minor modes.
 
-(defun easy-mmode-define-keymap (keymap-alist &optional menu-name)
-  "Return a keymap built from KEYMAP-ALIST.
-KEYMAP-ALIST must be a list of (KEYBINDING . BINDING) where
-KEYBINDING and BINDINGS are suited as for define-key.
-optional MENU-NAME is passed to `make-sparse-keymap'."
-  (let ((keymap (make-sparse-keymap menu-name)))
-    (mapcar
-     (function (lambda (bind)
-                 (define-key keymap
-                   (car bind) (cdr bind))))
-     keymap-alist)
-    keymap))
+;;; Code:
 
 (defmacro easy-mmode-define-toggle (mode &optional doc &rest body)
   "Define a one arg toggle mode MODE function and associated hooks.
@@ -161,6 +151,181 @@ Use the function `%s' to change this variable." mode-name))
        (setcdr (assq ',mode minor-mode-map-alist)
                ,keymap-sym)) ))
 
+
+;;;
+;;; easy-mmode-defmap
+;;;
+
+(if (fboundp 'set-keymap-parents)
+    (defalias 'easy-mmode-set-keymap-parents 'set-keymap-parents)
+  (defun easy-mmode-set-keymap-parents (m parents)
+    (set-keymap-parent
+     m
+     (cond
+      ((not (consp parents)) parents)
+      ((not (cdr parents)) (car parents))
+      (t (let ((m (copy-keymap (pop parents))))
+           (easy-mmode-set-keymap-parents m parents)
+           m))))))
+
+(defun easy-mmode-define-keymap (bs &optional name m args)
+  "Return a keymap built from bindings BS.
+BS must be a list of (KEY . BINDING) where
+KEY and BINDINGS are suited as for define-key.
+optional NAME is passed to `make-sparse-keymap'.
+optional map M can be used to modify an existing map.
+ARGS is a list of additional arguments."
+  (let (inherit dense suppress)
+    (while args
+      (let ((key (pop args))
+            (val (pop args)))
+        (cond
+         ((eq key :dense) (setq dense val))
+         ((eq key :inherit) (setq inherit val))
+         ((eq key :group) )
+         ;;((eq key :suppress) (setq suppress val))
+         (t (message "Unknown argument %s in defmap" key)))))
+    (unless (keymapp m)
+      (setq bs (append m bs))
+      (setq m (if dense (make-keymap name) (make-sparse-keymap name))))
+    (dolist (b bs)
+      (let ((keys (car b))
+            (binding (cdr b)))
+        (dolist (key (if (consp keys) keys (list keys)))
+          (cond
+           ((symbolp key)
+            (substitute-key-definition key binding m global-map))
+           ((null binding)
+            (unless (keymapp (lookup-key m key)) (define-key m key binding)))
+           ((let ((o (lookup-key m key)))
+              (or (null o) (numberp o) (eq o 'undefined)))
+            (define-key m key binding))))))
+    (cond
+     ((keymapp inherit) (set-keymap-parent m inherit))
+     ((consp inherit) (easy-mmode-set-keymap-parents m inherit)))
+    m))
+
+;;;###autoload
+(defmacro easy-mmode-defmap (m bs doc &rest args)
+  `(defconst ,m
+     (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args))
+     ,doc))
+
+
+;;;
+;;; easy-mmode-defsyntax
+;;;
+
+(defun easy-mmode-define-syntax (css args)
+  (let ((st (make-syntax-table (cadr (memq :copy args)))))
+    (dolist (cs css)
+      (let ((char (car cs))
+            (syntax (cdr cs)))
+        (if (sequencep char)
+            (mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char)
+          (modify-syntax-entry char syntax st))))
+    st))
+
+;;;###autoload
+(defmacro easy-mmode-defsyntax (st css doc &rest args)
+  `(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) doc))
+
+
+
+;;; A "macro-only" reimplementation of define-derived-mode.
+
+(defmacro easy-mmode-define-derived-mode (child parent name &optional docstring &rest body)
+  "Create a new mode as a variant of an existing mode.
+
+The arguments to this command are as follow:
+
+CHILD:     the name of the command for the derived mode.
+PARENT:    the name of the command for the parent mode (e.g. `text-mode').
+NAME:      a string which will appear in the status line (e.g. \"Hypertext\")
+DOCSTRING: an optional documentation string--if you do not supply one,
+           the function will attempt to invent something useful.
+BODY:      forms to execute just before running the
+           hooks for the new mode.
+
+Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode:
+
+  (define-derived-mode LaTeX-thesis-mode LaTeX-mode \"LaTeX-Thesis\")
+
+You could then make new key bindings for `LaTeX-thesis-mode-map'
+without changing regular LaTeX mode.  In this example, BODY is empty,
+and DOCSTRING is generated by default.
+
+On a more complicated level, the following command uses `sgml-mode' as
+the parent, and then sets the variable `case-fold-search' to nil:
+
+  (define-derived-mode article-mode sgml-mode \"Article\"
+    \"Major mode for editing technical articles.\"
+    (setq case-fold-search nil))
+
+Note that if the documentation string had been left out, it would have
+been generated automatically, with a reference to the keymap."
+
+                                        ; Some trickiness, since what
+                                        ; appears to be the docstring
+                                        ; may really be the first
+                                        ; element of the body.
+  (if (and docstring (not (stringp docstring)))
+      (progn (setq body (cons docstring body))
+             (setq docstring nil)))
+  (let* ((child-name (symbol-name child))
+         (map (intern (concat child-name "-map")))
+         (syntax (intern (concat child-name "-syntax-table")))
+         (abbrev (intern (concat child-name "-abbrev-table")))
+         (hook (intern (concat child-name "-hook"))))
+         
+  `(progn
+     (defvar ,map (make-sparse-keymap))
+     (defvar ,syntax (make-char-table 'syntax-table nil))
+     (defvar ,abbrev (progn (define-abbrev-table ',abbrev nil) ,abbrev))
+     
+     (defun ,child ()
+       ,(or docstring
+            (format "Major mode derived from `%s' by `define-derived-mode'.
+Inherits all of the parent's attributes, but has its own keymap,
+abbrev table and syntax table:
+
+  `%s', `%s' and `%s'
+
+which more-or-less shadow %s's corresponding tables.
+It also runs its own `%s' after its parent's.
+
+\\{%s}" parent map syntax abbrev parent hook map))
+       (interactive)
+                                        ; Run the parent.
+       (,parent)
+                                        ; Identify special modes.
+       (put ',child 'special (get ',parent 'special))
+                                        ; Identify the child mode.
+       (setq major-mode ',child)
+       (setq mode-name ,name)
+                                        ; Set up maps and tables.
+       (unless (keymap-parent ,map)
+         (set-keymap-parent ,map (current-local-map)))
+       (let ((parent (char-table-parent ,syntax)))
+         (unless (and parent (not (eq parent (standard-syntax-table))))
+           (set-char-table-parent ,syntax (syntax-table))))
+       (when local-abbrev-table
+         (mapatoms
+          (lambda (symbol)
+            (or (intern-soft (symbol-name symbol) ,abbrev)
+                (define-abbrev ,abbrev (symbol-name symbol)
+                  (symbol-value symbol) (symbol-function symbol))))
+          local-abbrev-table))
+       
+       (use-local-map ,map)
+       (set-syntax-table ,syntax)
+       (setq local-abbrev-table ,abbrev)
+                                        ; Splice in the body (if any).
+       ,@body
+                                        ; Run the hooks, if any.
+       (run-hooks ',hook)))))
+
+
 (provide 'easy-mmode)
 
 ;;; easy-mmode.el ends here