Package: emacs;
Reported by: Daniel Mendler <mail <at> daniel-mendler.de>
Date: Sun, 13 Feb 2022 22:40:02 UTC
Severity: wishlist
Found in version 28.0.91
Fixed in version 29.0.50
Done: Juri Linkov <juri <at> linkov.net>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Juri Linkov <juri <at> linkov.net> To: Eli Zaretskii <eliz <at> gnu.org> Cc: mail <at> daniel-mendler.de, 53981 <at> debbugs.gnu.org Subject: bug#53981: 28.0.91; shortdoc: Add support for outline-minor-mode Date: Wed, 09 Nov 2022 19:17:31 +0200
[Message part 1 (text/plain, inline)]
>> + (while (if outline-search-function >> + (funcall outline-search-function) >> + (re-search-forward outline-regexp nil t)) > > This changes the effect of the code because the new code searches for > a different regexp. Sorry, this was an attempt to unify code branches, but this change remained untested. Now fixed below. >> + (if outline-search-function >> + (funcall outline-search-function) >> + (re-search-forward >> + (concat "^\\(?:" outline-regexp "\\)") >> + nil 'move))) > > These two loops cons a new string each iteration. (So did the > original code, but if we are touching this, might as well fix that.) This is optimized as well:
[outline-search-level.patch (text/x-diff, inline)]
diff --git a/lisp/apropos.el b/lisp/apropos.el
index 624c29cb410..02a32a2e7ce 100644
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -493,7 +493,7 @@ apropos-mode
\\{apropos-mode-map}"
(make-local-variable 'apropos--current)
(setq-local revert-buffer-function #'apropos--revert-buffer)
- (setq-local outline-regexp "^[^ \n]+"
+ (setq-local outline-search-function #'outline-search-level
outline-level (lambda () 1)
outline-minor-mode-cycle t
outline-minor-mode-highlight t
@@ -1188,7 +1188,8 @@ apropos-print
(insert-text-button (symbol-name symbol)
'type 'apropos-symbol
'skip apropos-multi-type
- 'face 'apropos-symbol)
+ 'face 'apropos-symbol
+ 'outline-level 1)
(setq button-end (point))
(if (and (eq apropos-sort-by-scores 'verbose)
(cadr apropos-item))
diff --git a/lisp/outline.el b/lisp/outline.el
index a646f71db8b..fcac9d1950b 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -59,6 +59,14 @@ outline-heading-end-regexp
in the file it applies to.")
;;;###autoload(put 'outline-heading-end-regexp 'safe-local-variable 'stringp)
+(defvar outline-search-function nil
+ "Function to search the next outline heading.
+The function is called with two arguments: the limit of the search
+and the optional argument for the backward search; it should return
+non-nil, move point (to the end of the buffer when search fails),
+and set match-data appropriately if it succeeds;
+like re-search-forward with `outline-regexp' would.")
+
(defvar outline-mode-prefix-map
(let ((map (make-sparse-keymap)))
(define-key map "@" 'outline-mark-subtree)
@@ -233,7 +241,8 @@ outline-mode-map
(defvar outline-font-lock-keywords
'(
;; Highlight headings according to the level.
- (eval . (list (concat "^\\(?:" outline-regexp "\\).*")
+ (eval . (list (or outline-search-function
+ (concat "^\\(?:" outline-regexp "\\).*"))
0 '(if outline-minor-mode
(if outline-minor-mode-highlight
(list 'face (outline-font-lock-face)))
@@ -366,7 +375,9 @@ outline-font-lock-face
"Return one of `outline-font-lock-faces' for current level."
(save-excursion
(goto-char (match-beginning 0))
- (looking-at outline-regexp)
+ (if outline-search-function
+ (funcall outline-search-function nil nil t)
+ (looking-at outline-regexp))
(aref outline-font-lock-faces
(% (1- (funcall outline-level))
(length outline-font-lock-faces)))))
@@ -474,8 +485,11 @@ outline-minor-mode-highlight-buffer
;; Fallback to overlays when font-lock is unsupported.
(save-excursion
(goto-char (point-min))
- (let ((regexp (concat "^\\(?:" outline-regexp "\\).*$")))
- (while (re-search-forward regexp nil t)
+ (let ((regexp (unless outline-search-function
+ (concat "^\\(?:" outline-regexp "\\).*$"))))
+ (while (if outline-search-function
+ (funcall outline-search-function)
+ (re-search-forward regexp nil t))
(let ((overlay (make-overlay (match-beginning 0) (match-end 0))))
(overlay-put overlay 'outline-highlight t)
;; FIXME: Is it possible to override all underlying face attributes?
@@ -592,26 +606,32 @@ outline-next-preface
"Skip forward to just before the next heading line.
If there's no following heading line, stop before the newline
at the end of the buffer."
- (if (re-search-forward (concat "\n\\(?:" outline-regexp "\\)")
- nil 'move)
- (goto-char (match-beginning 0)))
- (if (and (bolp) (or outline-blank-line (eobp)) (not (bobp)))
- (forward-char -1)))
+ (when (if outline-search-function
+ (funcall outline-search-function)
+ (re-search-forward (concat "\n\\(?:" outline-regexp "\\)")
+ nil 'move))
+ (goto-char (match-beginning 0)))
+ (when (and (bolp) (or outline-blank-line (eobp)) (not (bobp)))
+ (forward-char -1)))
(defun outline-next-heading ()
"Move to the next (possibly invisible) heading line."
(interactive)
;; Make sure we don't match the heading we're at.
- (if (and (bolp) (not (eobp))) (forward-char 1))
- (if (re-search-forward (concat "^\\(?:" outline-regexp "\\)")
- nil 'move)
- (goto-char (match-beginning 0))))
+ (when (and (bolp) (not (eobp))) (forward-char 1))
+ (when (if outline-search-function
+ (funcall outline-search-function)
+ (re-search-forward (concat "^\\(?:" outline-regexp "\\)")
+ nil 'move))
+ (goto-char (match-beginning 0))))
(defun outline-previous-heading ()
"Move to the previous (possibly invisible) heading line."
(interactive)
- (re-search-backward (concat "^\\(?:" outline-regexp "\\)")
- nil 'move))
+ (if outline-search-function
+ (funcall outline-search-function nil t)
+ (re-search-backward (concat "^\\(?:" outline-regexp "\\)")
+ nil 'move)))
(defsubst outline-invisible-p (&optional pos)
"Non-nil if the character after POS has outline invisible property.
@@ -628,8 +648,10 @@ outline-back-to-heading
(let (found)
(save-excursion
(while (not found)
- (or (re-search-backward (concat "^\\(?:" outline-regexp "\\)")
- nil t)
+ (or (if outline-search-function
+ (funcall outline-search-function nil t)
+ (re-search-backward (concat "^\\(?:" outline-regexp "\\)")
+ nil t))
(signal 'outline-before-first-heading nil))
(setq found (and (or invisible-ok (not (outline-invisible-p)))
(point)))))
@@ -642,7 +664,9 @@ outline-on-heading-p
(save-excursion
(beginning-of-line)
(and (bolp) (or invisible-ok (not (outline-invisible-p)))
- (looking-at outline-regexp))))
+ (if outline-search-function
+ (funcall outline-search-function nil nil t)
+ (looking-at outline-regexp)))))
(defun outline-insert-heading ()
"Insert a new heading at same depth at point."
@@ -754,7 +778,9 @@ outline-demote
(while (and (progn (outline-next-heading) (not (eobp)))
(<= (funcall outline-level) level))))
(unless (eobp)
- (looking-at outline-regexp)
+ (if outline-search-function
+ (funcall outline-search-function nil nil t)
+ (looking-at outline-regexp))
(match-string-no-properties 0))))
;; Bummer!! There is no higher-level heading in the buffer.
(outline-invent-heading head nil))))
@@ -805,7 +831,9 @@ outline-map-region
(save-excursion
(setq end (copy-marker end))
(goto-char beg)
- (when (re-search-forward (concat "^\\(?:" outline-regexp "\\)") end t)
+ (when (if outline-search-function
+ (funcall outline-search-function)
+ (re-search-forward (concat "^\\(?:" outline-regexp "\\)") end t))
(goto-char (match-beginning 0))
(funcall fun)
(while (and (progn
@@ -873,21 +901,23 @@ outline-next-visible-heading
(if (< arg 0)
(beginning-of-line)
(end-of-line))
- (let (found-heading-p)
+ (let ((regexp (unless outline-search-function
+ (concat "^\\(?:" outline-regexp "\\)")))
+ found-heading-p)
(while (and (not (bobp)) (< arg 0))
(while (and (not (bobp))
(setq found-heading-p
- (re-search-backward
- (concat "^\\(?:" outline-regexp "\\)")
- nil 'move))
+ (if outline-search-function
+ (funcall outline-search-function nil t)
+ (re-search-backward regexp nil 'move)))
(outline-invisible-p)))
(setq arg (1+ arg)))
(while (and (not (eobp)) (> arg 0))
(while (and (not (eobp))
(setq found-heading-p
- (re-search-forward
- (concat "^\\(?:" outline-regexp "\\)")
- nil 'move))
+ (if outline-search-function
+ (funcall outline-search-function)
+ (re-search-forward regexp nil 'move)))
(outline-invisible-p (match-beginning 0))))
(setq arg (1- arg)))
(if found-heading-p (beginning-of-line))))
@@ -1108,7 +1138,9 @@ outline-hide-sublevels
(cond
(current-prefix-arg (prefix-numeric-value current-prefix-arg))
((save-excursion (beginning-of-line)
- (looking-at outline-regexp))
+ (if outline-search-function
+ (funcall outline-search-function nil nil t)
+ (looking-at outline-regexp)))
(funcall outline-level))
(t 1))))
(if (< levels 1)
@@ -1255,7 +1287,9 @@ outline-up-heading
(setq level (funcall outline-level)))
(setq start-level level))
(setq arg (- arg 1))))
- (looking-at outline-regexp))
+ (if outline-search-function
+ (funcall outline-search-function nil nil t)
+ (looking-at outline-regexp)))
(defun outline-forward-same-level (arg)
"Move forward to the ARG'th subheading at same level as this one.
@@ -1346,6 +1380,38 @@ outline-headers-as-kill
(insert "\n\n"))))))
(kill-new (buffer-string)))))))
+
+;;; Search text-property for outline headings
+
+;;;###autoload
+(defun outline-search-level (&optional limit backward looking-at)
+ (outline-search-text-property 'outline-level limit backward looking-at))
+
+(defun outline-search-text-property (prop &optional limit backward looking-at)
+ (let* ((prop-at
+ (if looking-at
+ (get-text-property (point) prop)
+ (when (get-text-property (point) prop)
+ ;; Go to the end of the current heading
+ (if backward
+ (text-property-search-backward prop)
+ (text-property-search-forward prop)))
+ t))
+ (prop-match
+ (when prop-at
+ (if backward
+ (text-property-search-backward prop)
+ (text-property-search-forward prop)))))
+ (if prop-match
+ (let ((beg (prop-match-beginning prop-match))
+ (end (prop-match-end prop-match)))
+ (if (or (null limit) (< end limit))
+ (set-match-data (list beg end))
+ (goto-char (or limit (point-max))))
+ t)
+ (goto-char (point-max))
+ nil)))
+
;;; Initial visibility
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index dbac03432c1..18b758a9ca3 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -1374,7 +1374,12 @@ shortdoc-display-group
(unless (bobp)
(insert "\n"))
(insert (propertize
- (concat (substitute-command-keys data) "\n\n")
+ (substitute-command-keys data)
+ 'face 'shortdoc-heading
+ 'shortdoc-section t
+ 'outline-level 1))
+ (insert (propertize
+ "\n\n"
'face 'shortdoc-heading
'shortdoc-section t)))
;; There may be functions not yet defined in the data.
@@ -1397,7 +1402,7 @@ shortdoc--display-function
(start-section (point))
arglist-start)
;; Function calling convention.
- (insert (propertize "(" 'shortdoc-function function))
+ (insert (propertize "(" 'shortdoc-function function 'outline-level 2))
(if (plist-get data :no-manual)
(insert-text-button
(symbol-name function)
@@ -1531,7 +1536,9 @@ shortdoc-mode-map
(define-derived-mode shortdoc-mode special-mode "shortdoc"
"Mode for shortdoc."
- :interactive nil)
+ :interactive nil
+ (setq-local outline-search-function #'outline-search-level)
+ (setq-local outline-level (lambda () (get-text-property (point) 'outline-level))))
(defun shortdoc--goto-section (arg sym &optional reverse)
(unless (natnump arg)
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.