X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/e4ad5f9e5f7b0b98399c7912ce41eb362fde5c11..937640a621a4ce2e5e56eaecca37a2a28a584318:/lisp/emacs-lisp/easy-mmode.el diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 069430a7aa..b6b91710ed 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -1,9 +1,11 @@ -;;; easy-mmode.el --- easy definition for major and minor modes. +;;; easy-mmode.el --- easy definition for major and minor modes -;; Copyright (C) 1997 Free Software Foundation, Inc. +;; Copyright (C) 1997,2000,01,02,03,2004 Free Software Foundation, Inc. -;; Author: Georges Brun-Cottan -;; Maintainer: Stefan Monnier +;; Author: Georges Brun-Cottan +;; Maintainer: Stefan Monnier + +;; Keywords: extensions lisp ;; This file is part of GNU Emacs. @@ -33,11 +35,11 @@ ;; For each mode, easy-mmode defines the following: ;; : The minor mode predicate. A buffer-local variable. ;; -map : The keymap possibly associated to . -;; -hook,-on-hook,-off-hook and -mode: -;; see `easy-mmode-define-minor-mode' documentation +;; -hook : The hook run at the end of the toggle function. +;; see `define-minor-mode' documentation ;; ;; eval -;; (pp (macroexpand '(easy-mmode-define-minor-mode ))) +;; (pp (macroexpand '(define-minor-mode ))) ;; to check the result before using it. ;; The order in which minor modes are installed is important. Keymap @@ -51,107 +53,280 @@ ;;; Code: -(defmacro easy-mmode-define-toggle (mode &optional doc &rest body) - "Define a one arg toggle mode MODE function and associated hooks. -MODE is the so defined function that toggles the mode. -optional DOC is its associated documentation. -BODY is executed after the toggling and before running the hooks. - -Hooks are checked for run, each time MODE-mode is called. -They run under the followings conditions: -MODE-hook: if the mode is toggled. -MODE-on-hook: if the mode is on. -MODE-off-hook: if the mode is off. - -When the mode is effectively toggled, two hooks may run. -If so MODE-hook is guaranteed to be the first." - (let* ((mode-name (symbol-name mode)) - (hook (intern (concat mode-name "-hook"))) - (hook-on (intern (concat mode-name "-on-hook"))) - (hook-off (intern (concat mode-name "-off-hook"))) - (toggle-doc (or doc - (format "With no argument, toggle %s. -With universal prefix ARG turn mode on. -With zero or negative ARG turn mode off. -\\{%s}" mode-name (concat mode-name "-map"))))) - `(progn - (defcustom ,hook nil - ,(format "Hook called when `%s' is toggled" mode-name) - :type 'hook) - - (defcustom ,hook-on nil - ,(format "Hook called when `%s' is turned on" mode-name) - :type 'hook) - - (defcustom ,hook-off nil - ,(format "Hook called when `%s' is turned off" mode-name) - :type 'hook) - - (defun ,mode (&optional arg) - ,toggle-doc - (interactive "P") - (let ((old-mode ,mode)) - (setq ,mode - (if arg - (> (prefix-numeric-value arg) 0) - (not ,mode))) - ,@body - (unless (equal old-mode ,mode) (run-hooks ',hook)) - (run-hooks (if ,mode ',hook-on ',hook-off))))))) +(eval-when-compile (require 'cl)) + +(defun easy-mmode-pretty-mode-name (mode &optional lighter) + "Turn the symbol MODE into a string intended for the user. +If provided LIGHTER will be used to help choose capitalization." + (let* ((case-fold-search t) + (name (concat (replace-regexp-in-string + "-Minor" " minor" + (capitalize (replace-regexp-in-string + "-mode\\'" "" (symbol-name mode)))) + " mode"))) + (if (not (stringp lighter)) name + (setq lighter (replace-regexp-in-string "\\`\\s-+\\|\\-s+\\'" "" lighter)) + (replace-regexp-in-string lighter lighter name t t)))) ;;;###autoload (defalias 'easy-mmode-define-minor-mode 'define-minor-mode) ;;;###autoload (defmacro define-minor-mode (mode doc &optional init-value lighter keymap &rest body) "Define a new minor mode MODE. -This function defines the associated control variable, keymap, -toggle command, and hooks (see `easy-mmode-define-toggle'). +This function defines the associated control variable MODE, keymap MODE-map, +toggle command MODE, and hook MODE-hook. DOC is the documentation for the mode toggle command. Optional INIT-VALUE is the initial value of the mode's variable. -Optional LIGHTER is displayed in the mode-bar when the mode is on. +Optional LIGHTER is displayed in the modeline when the mode is on. Optional KEYMAP is the default (defvar) keymap bound to the mode keymap. -If it is a list, it is passed to `easy-mmode-define-keymap' -in order to build a valid keymap. + If it is a list, it is passed to `easy-mmode-define-keymap' + in order to build a valid keymap. It's generally better to use + a separate MODE-map variable than to use this argument. +The above three arguments can be skipped if keyword arguments are +used (see below). + BODY contains code that will be executed each time the mode is (dis)activated. -It will be executed after any toggling but before running the hooks." + It will be executed after any toggling but before running the hooks. + Before the actual body code, you can write + keyword arguments (alternating keywords and values). + These following keyword arguments are supported (other keywords + will be passed to `defcustom' if the minor mode is global): +:group GROUP Custom group name to use in all generated `defcustom' forms. +:global GLOBAL If non-nil specifies that the minor mode is not meant to be + buffer-local, so don't make the variable MODE buffer-local. + By default, the mode is buffer-local. +:init-value VAL Same as the INIT-VALUE argument. +:lighter SPEC Same as the LIGHTER argument. +:keymap MAP Same as the KEYMAP argument. +:require SYM Same as in `defcustom'. + +For example, you could write + (define-minor-mode foo-mode \"If enabled, foo on you!\" + :lighter \" Foo\" :require 'foo :global t :group 'hassle :version \"27.5\" + ...BODY CODE...)" + (declare (debug (&define name stringp + [&optional [¬ keywordp] sexp + &optional [¬ keywordp] sexp + &optional [¬ keywordp] sexp] + [&rest [keywordp sexp]] + def-body))) + + ;; Allow skipping the first three args. + (cond + ((keywordp init-value) + (setq body (list* init-value lighter keymap body) + init-value nil lighter nil keymap nil)) + ((keywordp lighter) + (setq body (list* lighter keymap body) lighter nil keymap nil)) + ((keywordp keymap) (push keymap body) (setq keymap nil))) + (let* ((mode-name (symbol-name mode)) - (mode-doc (format "Non-nil if mode is enabled. -Use the function `%s' to change this variable." mode-name)) - (keymap-sym (intern (concat mode-name "-map"))) - (keymap-doc (format "Keymap for `%s'." mode-name))) + (pretty-name (easy-mmode-pretty-mode-name mode lighter)) + (globalp nil) + (group nil) + (extra-args nil) + (extra-keywords nil) + (require t) + (hook (intern (concat mode-name "-hook"))) + (hook-on (intern (concat mode-name "-on-hook"))) + (hook-off (intern (concat mode-name "-off-hook"))) + keyw keymap-sym) + + ;; Check keys. + (while (keywordp (setq keyw (car body))) + (setq body (cdr body)) + (case keyw + (:init-value (setq init-value (pop body))) + (:lighter (setq lighter (pop body))) + (:global (setq globalp (pop body))) + (:extra-args (setq extra-args (pop body))) + (:group (setq group (nconc group (list :group (pop body))))) + (:require (setq require (pop body))) + (:keymap (setq keymap (pop body))) + (t (push keyw extra-keywords) (push (pop body) extra-keywords)))) + + (setq keymap-sym (if (and keymap (symbolp keymap)) keymap + (intern (concat mode-name "-map")))) + + (unless group + ;; We might as well provide a best-guess default group. + (setq group + `(:group ',(or (custom-current-group) + (intern (replace-regexp-in-string + "-mode\\'" "" mode-name)))))) + `(progn ;; Define the variable to enable or disable the mode. - (defvar ,mode ,init-value ,mode-doc) - (make-variable-buffer-local ',mode) + ,(if (not globalp) + `(progn + (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled. +Use the command `%s' to change this variable." pretty-name mode)) + (make-variable-buffer-local ',mode)) + + (let ((curfile (or (and (boundp 'byte-compile-current-file) + byte-compile-current-file) + load-file-name))) + `(defcustom ,mode ,init-value + ,(format "Non-nil if %s is enabled. +See the command `%s' for a description of this minor-mode. +Setting this variable directly does not take effect; +use either \\[customize] or the function `%s'." + pretty-name mode mode) + :set 'custom-set-minor-mode + :initialize 'custom-initialize-default + ,@group + :type 'boolean + ,@(cond + ((not (and curfile require)) nil) + ((not (eq require t)) `(:require ,require)) + (t `(:require + ',(intern (file-name-nondirectory + (file-name-sans-extension curfile)))))) + ,@(nreverse extra-keywords)))) + + ;; The actual function. + (defun ,mode (&optional arg ,@extra-args) + ,(or doc + (format (concat "Toggle %s on or off. +Interactively, with no prefix argument, toggle the mode. +With universal prefix ARG turn mode on. +With zero or negative ARG turn mode off. +\\{%s}") pretty-name keymap-sym)) + ;; Use `toggle' rather than (if ,mode 0 1) so that using + ;; repeat-command still does the toggling correctly. + (interactive (list (or current-prefix-arg 'toggle))) + (setq ,mode + (cond + ((eq arg 'toggle) (not ,mode)) + (arg (> (prefix-numeric-value arg) 0)) + (t + (if (null ,mode) t + (message + "Toggling %s off; better pass an explicit argument." + ',mode) + nil)))) + ,@body + ;; The on/off hooks are here for backward compatibility only. + (run-hooks ',hook (if ,mode ',hook-on ',hook-off)) + (if (called-interactively-p) + (progn + ,(if globalp `(customize-mark-as-set ',mode)) + (unless (current-message) + (message ,(format "%s %%sabled" pretty-name) + (if ,mode "en" "dis"))))) + (force-mode-line-update) + ;; Return the new setting. + ,mode) + + ;; Autoloading an easy-mmode-define-minor-mode autoloads + ;; everything up-to-here. + :autoload-end + + ;; The toggle's hook. + (defcustom ,hook nil + ,(format "Hook run at the end of function `%s'." mode-name) + ,@group + :type 'hook) ;; Define the minor-mode keymap. - ,(when keymap + ,(unless (symbolp keymap) ;nil is also a symbol. `(defvar ,keymap-sym - (cond ((and ,keymap (keymapp ,keymap)) - ,keymap) - ((listp ,keymap) - (easy-mmode-define-keymap ,keymap)) - (t (error "Invalid keymap %S" ,keymap))) - ,keymap-doc)) - - ;; Define the toggle and the hooks. - (easy-mmode-define-toggle ,mode ,doc ,@body) - - ;; Update the mode line. - (or (assq ',mode minor-mode-alist) - (setq minor-mode-alist - (cons (list ',mode nil) minor-mode-alist))) - (setcar (cdr (assq ',mode minor-mode-alist)) ,lighter) - - ;; Update the minor mode map. - (or (assq ',mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons ',mode nil) minor-mode-map-alist))) - (setcdr (assq ',mode minor-mode-map-alist) - ,keymap-sym)) )) - + (let ((m ,keymap)) + (cond ((keymapp m) m) + ((listp m) (easy-mmode-define-keymap m)) + (t (error "Invalid keymap %S" ,keymap)))) + ,(format "Keymap for `%s'." mode-name))) + + (add-minor-mode ',mode ',lighter + ,(if keymap keymap-sym + `(if (boundp ',keymap-sym) + (symbol-value ',keymap-sym)))) + + ;; If the mode is global, call the function according to the default. + ,(if globalp + `(if (and load-file-name (not (equal ,init-value ,mode))) + (eval-after-load load-file-name '(,mode (if ,mode 1 -1)))))))) +;;; +;;; make global minor mode +;;; + +;;;###autoload +(defmacro easy-mmode-define-global-mode (global-mode mode turn-on + &rest keys) + "Make GLOBAL-MODE out of the buffer-local minor MODE. +TURN-ON is a function that will be called with no args in every buffer + and that should try to turn MODE on if applicable for that buffer. +KEYS is a list of CL-style keyword arguments: +:group to specify the custom group." + (let* ((global-mode-name (symbol-name global-mode)) + (pretty-name (easy-mmode-pretty-mode-name mode)) + (pretty-global-name (easy-mmode-pretty-mode-name global-mode)) + (group nil) + (extra-args nil) + (buffers (intern (concat global-mode-name "-buffers"))) + (cmmh (intern (concat global-mode-name "-cmmh")))) + + ;; Check keys. + (while (keywordp (car keys)) + (case (pop keys) + (:extra-args (setq extra-args (pop keys))) + (:group (setq group (nconc group (list :group (pop keys))))) + (t (setq keys (cdr keys))))) + + (unless group + ;; We might as well provide a best-guess default group. + (setq group + `(:group ',(or (custom-current-group) + (intern (replace-regexp-in-string + "-mode\\'" "" (symbol-name mode))))))) + + `(progn + ;; The actual global minor-mode + (define-minor-mode ,global-mode + ,(format "Toggle %s in every buffer. +With prefix ARG, turn %s on if and only if ARG is positive. +%s is actually not turned on in every buffer but only in those +in which `%s' turns it on." + pretty-name pretty-global-name pretty-name turn-on) + :global t :extra-args ,extra-args ,@group + + ;; Setup hook to handle future mode changes and new buffers. + (if ,global-mode + (progn + (add-hook 'find-file-hook ',buffers) + (add-hook 'change-major-mode-hook ',cmmh)) + (remove-hook 'find-file-hook ',buffers) + (remove-hook 'change-major-mode-hook ',cmmh)) + + ;; Go through existing buffers. + (dolist (buf (buffer-list)) + (with-current-buffer buf + (if ,global-mode (,turn-on) (when ,mode (,mode -1)))))) + + ;; Autoloading easy-mmode-define-global-mode + ;; autoloads everything up-to-here. + :autoload-end + + ;; List of buffers left to process. + (defvar ,buffers nil) + + ;; The function that calls TURN-ON in each buffer. + (defun ,buffers () + (remove-hook 'post-command-hook ',buffers) + (while ,buffers + (let ((buf (pop ,buffers))) + (when (buffer-live-p buf) + (with-current-buffer buf (,turn-on)))))) + (put ',buffers 'definition-name ',global-mode) + + ;; The function that catches kill-all-local-variables. + (defun ,cmmh () + (add-to-list ',buffers (current-buffer)) + (add-hook 'post-command-hook ',buffers)) + (put ',cmmh 'definition-name ',global-mode)))) + ;;; ;;; easy-mmode-defmap ;;; @@ -168,22 +343,23 @@ Use the function `%s' to change this variable." mode-name)) (easy-mmode-set-keymap-parents m parents) m)))))) +;;;###autoload (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) +KEY and BINDINGS are suitable 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 keyword arguments." + (let (inherit dense) (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)) + (case key + (:name (setq name val)) + (:dense (setq dense val)) + (:inherit (setq inherit val)) + (:group) (t (message "Unknown argument %s in defmap" key))))) (unless (keymapp m) (setq bs (append m bs)) @@ -207,11 +383,9 @@ ARGS is a list of additional arguments." ;;;###autoload (defmacro easy-mmode-defmap (m bs doc &rest args) - `(progn - (autoload 'easy-mmode-define-keymap "easy-mmode") - (defconst ,m - (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) - ,doc))) + `(defconst ,m + (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) + ,doc)) ;;; @@ -219,128 +393,92 @@ ARGS is a list of additional arguments." ;;; (defun easy-mmode-define-syntax (css args) - (let ((st (make-syntax-table (cadr (memq :copy args))))) + (let ((st (make-syntax-table (plist-get args :copy))) + (parent (plist-get args :inherit))) (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)))) + (if parent (set-char-table-parent + st (if (symbolp parent) (symbol-value parent) parent))) st)) ;;;###autoload (defmacro easy-mmode-defsyntax (st css doc &rest args) + "Define variable ST as a syntax-table. +CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)." `(progn (autoload 'easy-mmode-define-syntax "easy-mmode") - (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) doc))) + (defconst ,st (easy-mmode-define-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." - - (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")))) - - (when (and docstring (not (stringp docstring))) - ;; DOCSTRING is really the first command and there's no docstring - (push docstring body) - (setq docstring nil)) - - (unless (stringp docstring) - ;; Use a default docstring. - (setq 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." - parent map syntax abbrev parent))) - - (unless (string-match (regexp-quote (symbol-name hook)) docstring) - ;; Make sure the docstring mentions the mode's hook - (setq docstring (format "%s -This mode runs (additionally to any hooks his parent might have run) -its own `%s' just before exiting." - docstring hook))) - - (unless (string-match "\\\\[{[]" docstring) - ;; And don't forget to put the mode's keymap - (setq docstring (concat docstring "\n\\{" (symbol-name map) "}"))) +;;; +;;; easy-mmode-define-navigation +;;; +(defmacro easy-mmode-define-navigation (base re &optional name endfun narrowfun) + "Define BASE-next and BASE-prev to navigate in the buffer. +RE determines the places the commands should move point to. +NAME should describe the entities matched by RE. It is used to build + the docstrings of the two functions. +BASE-next also tries to make sure that the whole entry is visible by + searching for its end (by calling ENDFUN if provided or by looking for + the next entry) and recentering if necessary. +ENDFUN should return the end position (with or without moving point). +NARROWFUN non-nil means to check for narrowing before moving, and if +found, do widen first and then call NARROWFUN with no args after moving." + (let* ((base-name (symbol-name base)) + (prev-sym (intern (concat base-name "-prev"))) + (next-sym (intern (concat base-name "-next"))) + (check-narrow-maybe + (when narrowfun + '(setq was-narrowed + (prog1 (or (< (- (point-max) (point-min)) (buffer-size))) + (widen))))) + (re-narrow-maybe (when narrowfun + `(when was-narrowed (,narrowfun))))) + (unless name (setq name base-name)) `(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 () - ,docstring + (add-to-list 'debug-ignored-errors + ,(concat "^No \\(previous\\|next\\) " (regexp-quote name))) + (defun ,next-sym (&optional count) + ,(format "Go to the next COUNT'th %s." name) (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))))) + (unless count (setq count 1)) + (if (< count 0) (,prev-sym (- count)) + (if (looking-at ,re) (setq count (1+ count))) + (let (was-narrowed) + ,check-narrow-maybe + (if (not (re-search-forward ,re nil t count)) + (if (looking-at ,re) + (goto-char (or ,(if endfun `(,endfun)) (point-max))) + (error "No next %s" ,name)) + (goto-char (match-beginning 0)) + (when (and (eq (current-buffer) (window-buffer (selected-window))) + (interactive-p)) + (let ((endpt (or (save-excursion + ,(if endfun `(,endfun) + `(re-search-forward ,re nil t 2))) + (point-max)))) + (unless (pos-visible-in-window-p endpt nil t) + (recenter '(0)))))) + ,re-narrow-maybe))) + (defun ,prev-sym (&optional count) + ,(format "Go to the previous COUNT'th %s" (or name base-name)) + (interactive) + (unless count (setq count 1)) + (if (< count 0) (,next-sym (- count)) + (let (was-narrowed) + ,check-narrow-maybe + (unless (re-search-backward ,re nil t count) + (error "No previous %s" ,name)) + ,re-narrow-maybe)))))) (provide 'easy-mmode) +;;; arch-tag: d48a5250-6961-4528-9cb0-3c9ea042a66a ;;; easy-mmode.el ends here