diff options
Diffstat (limited to 'lisp/emacs-lisp/easy-mmode.el')
| -rw-r--r-- | lisp/emacs-lisp/easy-mmode.el | 164 |
1 files changed, 99 insertions, 65 deletions
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 4aa12ceec60..9e239bfa3b4 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -81,6 +81,34 @@ replacing its case-insensitive matches with the literal string in LIGHTER." ;; space.) (replace-regexp-in-string (regexp-quote lighter) lighter name t t)))) +(defconst easy-mmode--arg-docstring + " + +If called interactively, enable %s if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise.") + +(defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym) + (let ((doc (or doc (format "Toggle %s on or off. + +\\{%s}" mode-pretty-name keymap-sym)))) + (if (string-match-p "\\bARG\\b" doc) + doc + (let* ((fill-prefix nil) + (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) + (fill-column (if (integerp docs-fc) docs-fc 65)) + (argdoc (format easy-mmode--arg-docstring mode-pretty-name)) + (filled (if (fboundp 'fill-region) + (with-temp-buffer + (insert argdoc) + (fill-region (point-min) (point-max) 'left t) + (buffer-string)) + argdoc))) + (replace-regexp-in-string "\\(\n\n\\|\\'\\)\\(.\\|\n\\)*\\'" + (concat filled "\\1") + doc nil nil 1))))) + ;;;###autoload (defalias 'easy-mmode-define-minor-mode 'define-minor-mode) ;;;###autoload @@ -101,7 +129,9 @@ non-positive integer, and enables the mode otherwise (including if the argument is omitted or nil or a positive integer). If DOC is nil, give the mode command a basic doc-string -documenting what its argument does. +documenting what its argument does. If the word \"ARG\" does not +appear in DOC, a paragraph is added to DOC explaining +usage of the mode argument. Optional INIT-VALUE is the initial value of the mode's variable. Optional LIGHTER is displayed in the mode line when the mode is on. @@ -195,30 +225,30 @@ For example, you could write (while (keywordp (setq keyw (car body))) (setq body (cdr body)) (pcase keyw - (`:init-value (setq init-value (pop body))) - (`:lighter (setq lighter (purecopy (pop body)))) - (`:global (setq globalp (pop body)) - (when (and globalp (symbolp mode)) - (setq setter `(setq-default ,mode)) - (setq getter `(default-value ',mode)))) - (`:extra-args (setq extra-args (pop body))) - (`:set (setq set (list :set (pop body)))) - (`:initialize (setq initialize (list :initialize (pop body)))) - (`:group (setq group (nconc group (list :group (pop body))))) - (`:type (setq type (list :type (pop body)))) - (`:require (setq require (pop body))) - (`:keymap (setq keymap (pop body))) - (`:variable (setq variable (pop body)) - (if (not (and (setq tmp (cdr-safe variable)) - (or (symbolp tmp) - (functionp tmp)))) - ;; PLACE is not of the form (GET . SET). - (progn - (setq setter `(setf ,variable)) - (setq getter variable)) - (setq getter (car variable)) - (setq setter `(funcall #',(cdr variable))))) - (`:after-hook (setq after-hook (pop body))) + (:init-value (setq init-value (pop body))) + (:lighter (setq lighter (purecopy (pop body)))) + (:global (setq globalp (pop body)) + (when (and globalp (symbolp mode)) + (setq setter `(setq-default ,mode)) + (setq getter `(default-value ',mode)))) + (:extra-args (setq extra-args (pop body))) + (:set (setq set (list :set (pop body)))) + (:initialize (setq initialize (list :initialize (pop body)))) + (:group (setq group (nconc group (list :group (pop body))))) + (:type (setq type (list :type (pop body)))) + (:require (setq require (pop body))) + (:keymap (setq keymap (pop body))) + (:variable (setq variable (pop body)) + (if (not (and (setq tmp (cdr-safe variable)) + (or (symbolp tmp) + (functionp tmp)))) + ;; PLACE is not of the form (GET . SET). + (progn + (setq setter `(setf ,variable)) + (setq getter variable)) + (setq getter (car variable)) + (setq setter `(funcall #',(cdr variable))))) + (:after-hook (setq after-hook (pop body))) (_ (push keyw extra-keywords) (push (pop body) extra-keywords)))) (setq keymap-sym (if (and keymap (symbolp keymap)) keymap @@ -270,12 +300,7 @@ or call the function `%s'.")))) ;; The actual function. (defun ,modefun (&optional arg ,@extra-args) - ,(or doc - (format (concat "Toggle %s on or off. -With a prefix argument ARG, enable %s if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. -\\{%s}") pretty-name pretty-name keymap-sym)) + ,(easy-mmode--mode-docstring doc 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))) @@ -346,18 +371,21 @@ No problems result if this variable is not bound. ;;;###autoload (defalias 'define-global-minor-mode 'define-globalized-minor-mode) ;;;###autoload -(defmacro define-globalized-minor-mode (global-mode mode turn-on &rest keys) +(defmacro define-globalized-minor-mode (global-mode mode turn-on &rest body) "Make a global mode GLOBAL-MODE corresponding to 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. As the minor mode - defined by this function is always global, any :global keyword is - ignored. Other keywords have the same meaning as in `define-minor-mode', - which see. In particular, :group specifies the custom group. - The most useful keywords are those that are passed on to the - `defcustom'. It normally makes no sense to pass the :lighter - or :keymap keywords to `define-globalized-minor-mode', since these - are usually passed to the buffer-local version of the minor mode. +Each of KEY VALUE is a pair of CL-style keyword arguments. As + the minor mode defined by this function is always global, any + :global keyword is ignored. Other keywords have the same + meaning as in `define-minor-mode', which see. In particular, + :group specifies the custom group. The most useful keywords + are those that are passed on to the `defcustom'. It normally + makes no sense to pass the :lighter or :keymap keywords to + `define-globalized-minor-mode', since these are usually passed + to the buffer-local version of the minor mode. +BODY contains code to execute each time the mode is enabled or disabled. + It is executed after toggling the mode, and before running GLOBAL-MODE-hook. If MODE's set-up depends on the major mode in effect when it was enabled, then disabling and reenabling MODE should make MODE work @@ -367,7 +395,9 @@ call another major mode in their body. When a major mode is initialized, MODE is actually turned on just after running the major mode's hook. However, MODE is not turned -on if the hook has explicitly disabled it." +on if the hook has explicitly disabled it. + +\(fn GLOBAL-MODE MODE TURN-ON [KEY VALUE]... BODY...)" (declare (doc-string 2)) (let* ((global-mode-name (symbol-name global-mode)) (mode-name (symbol-name mode)) @@ -387,21 +417,16 @@ on if the hook has explicitly disabled it." keyw) ;; Check keys. - (while (keywordp (setq keyw (car keys))) - (setq keys (cdr keys)) + (while (keywordp (setq keyw (car body))) + (pop body) (pcase keyw - (`:group (setq group (nconc group (list :group (pop keys))))) - (`:global (setq keys (cdr keys))) - (_ (push keyw extra-keywords) (push (pop keys) extra-keywords)))) - - (unless group - ;; We might as well provide a best-guess default group. - (setq group - `(:group ',(intern (replace-regexp-in-string - "-mode\\'" "" (symbol-name mode)))))) + (:group (setq group (nconc group (list :group (pop body))))) + (:global (pop body)) + (_ (push keyw extra-keywords) (push (pop body) extra-keywords)))) `(progn (progn + (put ',global-mode 'globalized-minor-mode t) :autoload-end (defvar ,MODE-major-mode nil) (make-variable-buffer-local ',MODE-major-mode)) @@ -435,7 +460,8 @@ See `%s' for more information on %s." ;; Go through existing buffers. (dolist (buf (buffer-list)) (with-current-buffer buf - (if ,global-mode (funcall #',turn-on) (when ,mode (,mode -1)))))) + (if ,global-mode (funcall #',turn-on) (when ,mode (,mode -1))))) + ,@body) ;; Autoloading define-globalized-minor-mode autoloads everything ;; up-to-here. @@ -516,11 +542,11 @@ Valid keywords and arguments are: (let ((key (pop args)) (val (pop args))) (pcase key - (`:name (setq name val)) - (`:dense (setq dense val)) - (`:inherit (setq inherit val)) - (`:suppress (setq suppress val)) - (`:group) + (:name (setq name val)) + (:dense (setq dense val)) + (:inherit (setq inherit val)) + (:suppress (setq suppress val)) + (:group) (_ (message "Unknown argument %s in defmap" key))))) (unless (keymapp m) (setq bs (append m bs)) @@ -549,6 +575,7 @@ Valid keywords and arguments are: "Define a constant M whose value is the result of `easy-mmode-define-keymap'. The M, BS, and ARGS arguments are as per that function. DOC is the constant's documentation." + (declare (indent 1)) `(defconst ,m (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) ,doc)) @@ -575,6 +602,7 @@ the constant's documentation." (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)." + (declare (indent 1)) `(progn (autoload 'easy-mmode-define-syntax "easy-mmode") (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc))) @@ -598,22 +626,22 @@ 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. BODY is executed after moving to the destination location." - (declare (indent 5) (debug (exp exp exp def-form def-form &rest def-body))) + (declare (indent 5) (debug (exp exp exp def-form def-form def-body))) (let* ((base-name (symbol-name base)) (prev-sym (intern (concat base-name "-prev"))) (next-sym (intern (concat base-name "-next"))) (when-narrowed (lambda (body) (if (null narrowfun) body - `(let ((was-narrowed - (prog1 (or (< (- (point-max) (point-min)) (buffer-size))) - (widen)))) + `(let ((was-narrowed (prog1 (buffer-narrowed-p) (widen)))) ,body (when was-narrowed (funcall #',narrowfun))))))) (unless name (setq name base-name)) + ;; FIXME: Move most of those functions's bodies to helper functions! `(progn (defun ,next-sym (&optional count) - ,(format "Go to the next COUNT'th %s." name) + ,(format "Go to the next COUNT'th %s. +Interactively, COUNT is the prefix numeric argument, and defaults to 1." name) (interactive "p") (unless count (setq count 1)) (if (< count 0) (,prev-sym (- count)) @@ -631,11 +659,17 @@ BODY is executed after moving to the destination location." `(re-search-forward ,re nil t 2))) (point-max)))) (unless (pos-visible-in-window-p endpt nil t) - (recenter '(0))))))) + (let ((ws (window-start))) + (recenter '(0)) + (if (< (window-start) ws) + ;; recenter scrolled in the wrong direction! + (set-window-start nil ws)))))))) ,@body)) (put ',next-sym 'definition-name ',base) (defun ,prev-sym (&optional count) - ,(format "Go to the previous COUNT'th %s" (or name base-name)) + ,(format "Go to the previous COUNT'th %s. +Interactively, COUNT is the prefix numeric argument, and defaults to 1." + (or name base-name)) (interactive "p") (unless count (setq count 1)) (if (< count 0) (,next-sym (- count)) |