(outline--hidden-headings-paths): Fix slow saves (bug#78665)

* lisp/outline.el: Prefer #' to quote function names.
(outline--end-of-previous): New function, extracted from
`outline-end-of-subtree`.
(outline-end-of-subtree): Use it.
(outline--hidden-headings-paths): Distinguish headings where just the
entry is hidden from those where a whole subtree is hidden (bug#78673).
(outline--hidden-headings-restore-paths): Adjust accordingly and don't
delegate to functions like `outline-hide-subtree` so as to avoid
an O(N²) behavior.

(cherry picked from commit 77a4c63fda5ca5d4c6d82092eaa06f1eb9b51302)

diff --git a/lisp/outline.el b/lisp/outline.el
index 71aa33c8b0468dcea8f8f0379b9aba98f5cab460..fb6714bb15a14971669dc508514d23ef30f02603 100644 (file)
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -235,10 +235,10 @@ The argument MAP is optional and defaults to `outline-minor-mode-cycle-map'."
   (let ((map (make-sparse-keymap)))
     (outline-minor-mode-cycle--bind map (kbd "TAB") #'outline-cycle)
     (outline-minor-mode-cycle--bind map (kbd "<backtab>") #'outline-cycle-buffer)
-    (keymap-set map "<left-margin> <mouse-1>" 'outline-cycle)
-    (keymap-set map "<right-margin> <mouse-1>" 'outline-cycle)
-    (keymap-set map "<left-margin> S-<mouse-1>" 'outline-cycle-buffer)
-    (keymap-set map "<right-margin> S-<mouse-1>" 'outline-cycle-buffer)
+    (keymap-set map "<left-margin> <mouse-1>" #'outline-cycle)
+    (keymap-set map "<right-margin> <mouse-1>" #'outline-cycle)
+    (keymap-set map "<left-margin> S-<mouse-1>" #'outline-cycle-buffer)
+    (keymap-set map "<right-margin> S-<mouse-1>" #'outline-cycle-buffer)
     map)
   "Keymap used as a parent of the `outline-minor-mode' keymap.
 It contains key bindings that can be used to cycle visibility.
@@ -483,7 +483,7 @@ Turning on outline mode calls the value of `text-mode-hook' and then of
 The value of this variable is checked as part of loading Outline mode.
 After that, changing the prefix key requires manipulating keymaps."
   :type 'key-sequence
-  :initialize 'custom-initialize-default
+  :initialize #'custom-initialize-default
   :set (lambda (sym val)
          (define-key outline-minor-mode-map outline-minor-mode-prefix nil)
          (define-key outline-minor-mode-map val outline-mode-prefix-map)
@@ -685,6 +685,7 @@ at the end of the buffer."
     (goto-char (match-beginning 0))
     ;; Compensate "\n" from the beginning of regexp
     (when (and outline-search-function (not (bobp))) (forward-char -1)))
+  ;; FIXME: Use `outline--end-of-previous'.
   (when (and (bolp) (or outline-blank-line (eobp)) (not (bobp)))
     (forward-char -1)))
 
@@ -1287,6 +1288,16 @@ This also unhides the top heading-less body, if any."
                          (progn (outline-end-of-subtree) (point))
                          flag)))
 
+(defun outline--end-of-previous ()
+  "Go back from BOH (or EOB) to end of previous element."
+  (if (eobp)
+      (if (bolp) (forward-char -1))
+    ;; Go to end of line before heading
+    (forward-char -1)
+    (if (and outline-blank-line (bolp))
+        ;; leave blank line before heading
+        (forward-char -1))))
+
 (defun outline-end-of-subtree ()
   "Move to the end of the current subtree."
   (outline-back-to-heading)
@@ -1298,12 +1309,7 @@ This also unhides the top heading-less body, if any."
       (outline-next-heading))
     (if (and (bolp) (not (eolp)))
        ;; We stopped at a nonempty line (the next heading).
-       (progn
-         ;; Go to end of line before heading
-         (forward-char -1)
-          (if (and outline-blank-line (bolp))
-             ;; leave blank line before heading
-             (forward-char -1))))))
+       (outline--end-of-previous))))
 \f
 (defun outline-show-branches ()
   "Show all subheadings of this heading, but not their bodies."
@@ -1717,12 +1723,17 @@ LEVEL, decides of subtree visibility according to
   (run-hooks 'outline-view-change-hook))
 
 (defun outline--hidden-headings-paths ()
-  "Return a hash with headings of currently hidden outlines.
-Every hash key is a list whose elements compose a complete path
+  "Return (HASH-TABLE CURRENT-HEADING).
+HASH-TABLE holds the headings of currently hidden outlines.
+Every key is a list whose elements compose a complete path
 of headings descending from the top level down to the bottom level.
+Every entry's value is non-nil if that entry should be hidden.
+The specific non-nil vale can be t to hide just the entry, or a number
+LEVEL to mean that not just the entry should be hidden but also all the
+subsequent elements of level higher or equal to LEVEL.
 This is useful to save the hidden outlines and restore them later
-after reverting the buffer.  Also return the outline where point
-was located before reverting the buffer."
+after reverting the buffer.
+CURRENT-HEADING is the heading where point is located."
   (let* ((paths (make-hash-table :test #'equal))
          path current-path
          (current-heading-p (outline-on-heading-p))
@@ -1730,40 +1741,60 @@ was located before reverting the buffer."
          (current-end (when current-heading-p (pos-eol))))
     (outline-map-region
      (lambda ()
-       (let* ((level (funcall outline-level))
-              (heading (buffer-substring-no-properties (pos-bol) (pos-eol))))
-         (while (and path (>= (cdar path) level))
-           (pop path))
-         (push (cons heading level) path)
-         (when (save-excursion
-                 (outline-end-of-heading)
-                 (seq-some (lambda (o) (eq (overlay-get o 'invisible)
-                                           'outline))
-                           (overlays-at (point))))
-           (setf (gethash (mapcar #'car path) paths) t))
+       (let ((level (funcall outline-level)))
+         (if (outline-invisible-p)
+             ;; Covered by "the" previous heading.
+             (cl-callf (lambda (l) (if (numberp l) (min l level) level))
+                 (gethash (mapcar #'car path) paths))
+           (let ((heading (buffer-substring-no-properties (pos-bol) (pos-eol))))
+             (while (and path (>= (cdar path) level))
+               (pop path))
+             (push (cons heading level) path)
+             (when (save-excursion
+                     (outline-end-of-heading)
+                     (outline-invisible-p))
+               (setf (gethash (mapcar #'car path) paths) t))))
          (when (and current-heading-p (<= current-beg (point) current-end))
            (setq current-path (mapcar #'car path)))))
      (point-min) (point-max))
     (list paths current-path)))
 
 (defun outline--hidden-headings-restore-paths (paths current-path)
-  "Restore hidden outlines from a hash of hidden headings.
+  "Restore hidden outlines from a hash-table of hidden headings.
 This is useful after reverting the buffer to restore the outlines
 hidden by `outline--hidden-headings-paths'.  Also restore point
 on the same outline where point was before reverting the buffer."
-  (let (path current-point outline-view-change-hook)
+  (let ((hidelevel nil) (hidestart nil)
+        path current-point outline-view-change-hook)
     (outline-map-region
      (lambda ()
-       (let* ((level (funcall outline-level))
-              (heading (buffer-substring (pos-bol) (pos-eol))))
-         (while (and path (>= (cdar path) level))
-           (pop path))
-         (push (cons heading level) path)
-         (when (gethash (mapcar #'car path) paths)
-           (outline-hide-subtree))
+       (let ((level (funcall outline-level)))
+         (if (and (numberp hidelevel) (<= hidelevel level))
+             nil
+           (when hidestart
+             (outline-flag-region hidestart
+                                  (save-excursion (outline--end-of-previous)
+                                                  (point))
+                                  t)
+             (setq hidestart nil))
+           (let* ((heading (buffer-substring-no-properties
+                            (pos-bol) (pos-eol))))
+             (while (and path (>= (cdar path) level))
+               (pop path))
+             (push (cons heading level) path)
+             (when (setq hidelevel (gethash (mapcar #'car path) paths))
+               (setq hidestart (save-excursion (outline-end-of-heading)
+                                               (point))))))
          (when (and current-path (equal current-path (mapcar #'car path)))
            (setq current-point (point)))))
      (point-min) (point-max))
+    (when hidestart
+      (outline-flag-region hidestart
+                           (save-excursion
+                             (goto-char (point-max))
+                             (outline--end-of-previous)
+                             (point))
+                           t))
     (when current-point (goto-char current-point))))
 
 (defun outline-revert-buffer-restore-visibility ()

diff --git a/lisp/transient.el b/lisp/transient.el
index 61611027d4087b732a0ea272a3e3aa7e79684a3e..fc9702f6444950905dcb8ae1f187d1fb29df61d4 100644 (file)
--- a/lisp/transient.el
+++ b/lisp/transient.el
@@ -72,7 +72,7 @@
   (transient--emergency-exit :debugger)
   (apply #'debug args))
 
-;;; Options
+;;;; Options
 
 (defgroup transient nil
   "Transient commands."
@@ -507,7 +507,7 @@ give you as many additional suffixes as you hoped.)"
   :group 'transient
   :type 'boolean)
 
-;;; Faces
+;;;; Faces
 
 (defgroup transient-faces nil
   "Faces used by Transient."
@@ -655,7 +655,7 @@ See also option `transient-highlight-mismatched-keys'."
 See also option `transient-highlight-mismatched-keys'."
   :group 'transient-faces)
 
-;;; Persistence
+;;;; Persistence
 
 (defun transient--read-file-contents (file)
   (with-demoted-errors "Transient error: %S"
@@ -718,7 +718,7 @@ If `transient-save-history' is nil, then do nothing."
 (unless noninteractive
   (add-hook 'kill-emacs-hook #'transient-maybe-save-history))
 
-;;; Classes
+;;;; Classes
 ;;;; Prefix
 
 (defclass transient-prefix ()
@@ -965,7 +965,7 @@ commands or strings.  This group inserts an empty line between
 subgroups.  The subgroups are responsible for displaying their
 elements themselves.")
 
-;;; Define
+;;;; Define
 
 (defmacro transient-define-prefix (name arglist &rest args)
   "Define NAME as a transient prefix command.
@@ -1482,7 +1482,7 @@ Intended for use in a group's `:setup-children' function."
     (setq prefix (oref prefix command)))
   (mapcar (apply-partially #'transient-parse-suffix prefix) suffixes))
 
-;;; Edit
+;;;; Edit
 
 (defun transient--insert-suffix (prefix loc suffix action &optional keep-other)
   (pcase-let* ((suf (cl-etypecase suffix
@@ -1699,7 +1699,7 @@ using `transient-define-suffix', `transient-define-infix' or
     (user-error "Cannot set level for `%s'; no prototype object exists"
                 command)))
 
-;;; Variables
+;;;; Variables
 
 (defvar transient-current-prefix nil
   "The transient from which this suffix command was invoked.
@@ -1806,7 +1806,7 @@ This is bound while the suffixes are drawn in the transient buffer.")
     mwheel-scroll
     scroll-bar-toolkit-scroll))
 
-;;; Identities
+;;;; Identities
 
 (defun transient-active-prefix (&optional prefixes)
   "Return the active transient object.
@@ -1944,7 +1944,7 @@ probably use this instead:
       (seq-some (lambda (cmd) (get cmd 'transient--suffix))
                 (function-alias-p command))))
 
-;;; Keymaps
+;;;; Keymaps
 
 (defvar-keymap transient-base-map
   :doc "Parent of other keymaps used by Transient.
@@ -2306,7 +2306,7 @@ of the corresponding object."
        transient--transient-map))
     topmap))
 
-;;; Setup
+;;;; Setup
 
 (defun transient-setup (&optional name layout edit &rest params)
   "Setup the transient specified by NAME.
@@ -2587,7 +2587,7 @@ value.  Otherwise return CHILDREN as is.")
     (transient--debug "   autoload %s" cmd)
     (autoload-do-load fn)))
 
-;;; Flow-Control
+;;;; Flow-Control
 
 (defun transient--setup-transient ()
   (transient--debug 'setup-transient)
@@ -2981,7 +2981,7 @@ identifying the exit."
     (transient--pre-exit)
     (transient--post-exit this-command)))
 
-;;; Pre-Commands
+;;;; Pre-Commands
 
 (defun transient--call-pre-command ()
   (if-let* ((fn (transient--get-pre-command this-command
@@ -3164,7 +3164,7 @@ prefix argument and pivot to `transient-update'."
 (put 'transient--do-move       'transient-face 'transient-key-stay)
 (put 'transient--do-minus      'transient-face 'transient-key-stay)
 
-;;; Commands
+;;;; Commands
 ;;;; Noop
 
 (defun transient-noop ()
@@ -3487,7 +3487,7 @@ such as when suggesting a new feature or reporting an issue."
                           arguments " "))
     (message "%s: %S" (key-description (this-command-keys)) arguments)))
 
-;;; Value
+;;;; Value
 ;;;; Init
 
 (cl-defgeneric transient-init-value (obj)
@@ -3999,7 +3999,7 @@ Append \"=\ to ARG to indicate that it is an option."
           (or (match-string 1 match) "")))
     (and (member arg args) t)))
 
-;;; Return
+;;;; Return
 
 (defun transient-init-return (obj)
   (when-let* ((transient--stack)
@@ -4011,7 +4011,7 @@ Append \"=\ to ARG to indicate that it is an option."
                      (list t 'recurse #'transient--do-recurse))))
     (oset obj return t)))
 
-;;; Scope
+;;;; Scope
 ;;;; Init
 
 (cl-defgeneric transient-init-scope (obj)
@@ -4083,7 +4083,7 @@ If no prefix matches, return nil."
     (and-let* ((obj (transient-prefix-object)))
       (oref obj scope))))
 
-;;; History
+;;;; History
 
 (cl-defgeneric transient--history-key (obj)
   "Return OBJ's history key.")
@@ -4115,7 +4115,7 @@ have a history of their own.")
           (cons val (delete val (alist-get (transient--history-key obj)
                                            transient-history))))))
 
-;;; Display
+;;;; Display
 
 (defun transient--show-hint ()
   (let ((message-log-max nil))
@@ -4189,7 +4189,7 @@ have a history of their own.")
                               (window-body-width window t)
                               (window-body-height window t))))
 
-;;; Delete
+;;;; Delete
 
 (defun transient--delete-window ()
   (when (window-live-p transient--window)
@@ -4223,7 +4223,7 @@ have a history of their own.")
       (setq show (natnump show)))
     show))
 
-;;; Format
+;;;; Format
 
 (defun transient--format-hint ()
   (if (and transient-show-popup (<= transient-show-popup 0))
@@ -4727,7 +4727,7 @@ a prefix command, while porting a regular keymap to a transient."
         (propertize (car (split-string doc "\n")) 'face 'font-lock-doc-face)
       (propertize (symbol-name command) 'face 'font-lock-function-name-face))))
 
-;;; Help
+;;;; Help
 
 (cl-defgeneric transient-show-help (obj)
   "Show documentation for the command represented by OBJ.")
@@ -5168,7 +5168,7 @@ as stand-in for elements of exhausted lists."
       (setq lists (mapcar #'cdr lists)))
     (nreverse result)))
 
-;;; Font-Lock
+;;;; Font-Lock
 
 (defconst transient-font-lock-keywords
   (eval-when-compile
@@ -5186,7 +5186,7 @@ as stand-in for elements of exhausted lists."
 
 (font-lock-add-keywords 'emacs-lisp-mode transient-font-lock-keywords)
 
-;;; Auxiliary Classes
+;;;; Auxiliary Classes
 ;;;; `transient-lisp-variable'
 
 (defclass transient-lisp-variable (transient-variable)
@@ -5249,4 +5249,4 @@ as stand-in for elements of exhausted lists."
 ;; indent-tabs-mode: nil
 ;; checkdoc-symbol-words: ("command-line" "edit-mode" "help-mode")
 ;; End:
-;;; transient.el ends here
+;;;; transient.el ends here