Mercurial > emacs

--- a/lisp/emacs-lisp/easy-mmode.el	Thu Mar 09 23:17:52 2000 +0000
+++ b/lisp/emacs-lisp/easy-mmode.el	Fri Mar 10 01:16:34 2000 +0000
@@ -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 @@
        (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