bug#53981: 28.0.91; shortdoc: Add support for outline-minor-mode

[Juri Linkov]

> The shortdoc buffer currently lacks support for the outline-minor-mode.
> By setting the two variables outline-regexp and outline-level, we can
> unlock this feature. Does it make sense to provide this by default?
>
> (defun shortdoc--outline-level () (if (eq (char-after) ?\() 2 1)))
> (add-hook 'shortdoc-mode-hook
>           (lambda ()
>             (setq-local outline-level #'shortdoc--outline-level
>                         outline-regexp "[A-Z(]")))

Unfortunately, outline-regexp is not a reliable way to find
outline headings.  For this reason currently outlines in apropos
are broken: outline-regexp in apropos-mode is set to "^[^ \n]+",
that matches too many false positives, all blue lines below
are incorrectly identified as outline headings:

As previously discussed, we need to introduce a new function
to search outline headings.  Using such function, the outlines
are identified with 100% precision:

Here is a patch that adds 'outline-search-function'.  However,
the requirements for this function arguments are quite non-standard:
its first argument should be a limit that is used in
outline-font-lock-keywords where MATCHER has the argument LIMIT.
Also the same function should be able to search in both directions:
forward and backward.  And the third requirement is that it should be
able also to be used as looking-at without moving point.  In this patch
the second argument HOW supports two values: 'backward' and 'looking-at'.
But this could be split to two separate boolean arguments,
this is not the final patch.  Also another optional argument
could be added to define an arbitrary property to search.

Then here the same function is used for apropos-mode and shortdoc:

diff --git a/lisp/apropos.el b/lisp/apropos.el
index 624c29cb410..5b7fe4cb23a 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-prop
               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..442d51b71bc 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 'looking-at)
+      (looking-at outline-regexp))
     (aref outline-font-lock-faces
           (% (1- (funcall outline-level))
              (length outline-font-lock-faces)))))
@@ -474,16 +485,17 @@ 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 ((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?
-          (when (or (memq outline-minor-mode-highlight '(append override))
-                    (and (eq outline-minor-mode-highlight t)
-                         (not (get-text-property (match-beginning 0) 'face))))
-            (overlay-put overlay 'face (outline-font-lock-face))))
-        (goto-char (match-end 0))))))
+    (while (if outline-search-function
+               (funcall outline-search-function)
+             (re-search-forward outline-regexp nil t))
+      (let ((overlay (make-overlay (match-beginning 0) (pos-eol))))
+        (overlay-put overlay 'outline-highlight t)
+        ;; FIXME: Is it possible to override all underlying face attributes?
+        (when (or (memq outline-minor-mode-highlight '(append override))
+                  (and (eq outline-minor-mode-highlight t)
+                       (not (get-text-property (match-beginning 0) 'face))))
+          (overlay-put overlay 'face (outline-font-lock-face))))
+      (move-end-of-line 1))))
 
 ;;;###autoload
 (define-minor-mode outline-minor-mode
@@ -592,26 +604,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 'backward)
+    (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 +646,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 'backward)
+                  (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 +662,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 'looking-at)
+           (looking-at outline-regexp)))))
 
 (defun outline-insert-heading ()
   "Insert a new heading at same depth at point."
@@ -754,7 +776,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 'looking-at)
+                        (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 +829,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
@@ -877,17 +903,21 @@ outline-next-visible-heading
     (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 'backward)
+                          (re-search-backward
+                          (concat "^\\(?:" outline-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
+                          (concat "^\\(?:" outline-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 
'looking-at)
+                                    (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 'looking-at)
+    (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,35 @@ outline-headers-as-kill
                     (insert "\n\n"))))))
           (kill-new (buffer-string)))))))
 
+
+;;; Search text-property for outline headings
+
+(defun outline-search-level-prop (&optional limit how)
+  (let* ((prop 'outline-level)
+         (prop-at
+          (if (eq how 'looking-at)
+              (get-text-property (point) prop)
+            (when (get-text-property (point) prop)
+              ;; Go to the end of the current heading
+              (if (eq how 'backward)
+                  (text-property-search-backward prop)
+                (text-property-search-forward prop)))
+            t))
+         (prop-match
+          (when prop-at
+            (if (eq how '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..d3c824a4e93 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-prop)
+  (setq-local outline-level (lambda () (get-text-property (point) 
'outline-level))))
 
 (defun shortdoc--goto-section (arg sym &optional reverse)
   (unless (natnump arg)