Add hs-preserve-mode.el
This commit is contained in:
@@ -0,0 +1,278 @@
|
||||
;;; hs-preserve-mode.el --- Minor mode to preserve hideshow.el folds. -*- lexical-binding: t -*-
|
||||
;;; Commentary:
|
||||
;;; This package was inspired by `https://github.com/jcfk/savefold.el`.
|
||||
;;;
|
||||
;;; Code:
|
||||
(eval-when-compile
|
||||
(require 'cl-lib))
|
||||
|
||||
(defgroup hs-preserve-mode nil
|
||||
"Minor mode to preserve hideshow.el folds."
|
||||
:group 'hideshow
|
||||
:prefix "hs-preserve-mode-")
|
||||
|
||||
(defcustom hs-preserve-mode-db-directory
|
||||
(if (fboundp 'no-littering-expand-var-file-name)
|
||||
(no-littering-expand-var-file-name "hs-preserve-mode/")
|
||||
(expand-file-name "hs-preserve-mode/" user-emacs-directory))
|
||||
"Directory in which to store hs-preserve-mode DB files.
|
||||
These are the files that contain the saved fold information."
|
||||
:type 'string
|
||||
:group 'hs-preserve-mode)
|
||||
|
||||
(defcustom hs-preserve-mode-db-directory-mode #o700
|
||||
"File mode to create `hs-preserve-mode-db-directory' with."
|
||||
:type 'natnum
|
||||
:group 'hs-preserve-mode)
|
||||
|
||||
(defcustom hs-preserve-mode-filter-functions
|
||||
'(hs-preserve-mode-hs-minor-mode-filter-function)
|
||||
"Hook of one argument to filter buffer overlays.
|
||||
Each function in this list will be called in order on each buffer overlay until
|
||||
one of the function returns non-nil. If one of the functions returned non-nil,
|
||||
the overlay is persisted, otherwise, it is not.
|
||||
|
||||
If the first function to return non-nil returned a list, it is used as the plist
|
||||
of the overlay to save. If it returned t, save all properties in the overlay.
|
||||
|
||||
This is a hook and should be modified with `add-hook'."
|
||||
:type 'hook
|
||||
:group 'hs-preserve-mode)
|
||||
|
||||
(defcustom hs-preserve-mode-trigger-hooks
|
||||
'(after-save-hook (hs-show-hook . nil) (hs-hide-hook . nil))
|
||||
"List of hooks to trigger saving of the folds database.
|
||||
This variable is a list of hook variables. Each element takes one of two forms:
|
||||
- SYMBOL -> always save the database when the hook SYMBOL is run
|
||||
- (SYMBOL . t) -> save the database if SYMBOL is run and the buffer is modified
|
||||
- (SYMBOL . nil) -> likewise if the buffer is not modified"
|
||||
:type '(repeat
|
||||
(choice (symbol :tag "Unconditional hook")
|
||||
(cons :tag "Conditional hook"
|
||||
(symbol :tag "Hook variable")
|
||||
(choice (const :tag "If buffer modified" t)
|
||||
(const :tag "If buffer unmodified" nil)))))
|
||||
:group 'hs-preserve-mode)
|
||||
|
||||
(defcustom hs-preserve-mode-silent-db-writes t
|
||||
"Whether or not to print messages after writing the database file.
|
||||
If this is t, print messages normally, if it is nil, suppress the messages (they
|
||||
will appear in the *Messages* buffer, if this is any other non-nil value,
|
||||
inhibit messages all together."
|
||||
:type '(choice (const :tag "Print messages" nil)
|
||||
(const :tag "Suppress messages (show in *Messages*)" t)
|
||||
(const :tag "Inhibit messages" inhibit))
|
||||
:group 'hs-preserve-mode)
|
||||
|
||||
(defun hs-preserve-mode-hs-minor-mode-filter-function (ov)
|
||||
"`hs-preserve-mode' filter function for `hs-minor-mode'.
|
||||
OV is the overlay to filter."
|
||||
(and (overlay-get ov 'hs) t))
|
||||
|
||||
(defun hs-preserve-mode--db-file-path (&optional path)
|
||||
"Return the DB file path for PATH.
|
||||
PATH defaults to the current buffer's visited file. PATH must not have multiple
|
||||
separators between directories. That is \"a//b\" will result in invalid return
|
||||
values."
|
||||
(expand-file-name
|
||||
(string-replace "/" "%" (string-replace "%" "%%" (or path buffer-file-name)))
|
||||
hs-preserve-mode-db-directory))
|
||||
|
||||
(defun hs-preserve-mode--file-modification-time (path)
|
||||
"Return the modification time of PATH as an float."
|
||||
(if-let* ((attrs (file-attributes path)))
|
||||
(cl-destructuring-bind (ticks . hz)
|
||||
(time-convert (file-attribute-modification-time attrs) t)
|
||||
(/ (float ticks) hz))
|
||||
(signal 'file-missing path)))
|
||||
|
||||
(defun hs-preserve-mode--more-recently-modified-p (f1 f2)
|
||||
"Return non-nil if F1 was more recently modified than F2."
|
||||
(> (hs-preserve-mode--file-modification-time f1)
|
||||
(hs-preserve-mode--file-modification-time f2)))
|
||||
|
||||
(defun hs-preserve-mode--ensure-db-directory ()
|
||||
"Ensure the DB directory is created and has the correct permissions."
|
||||
(make-directory hs-preserve-mode-db-directory t)
|
||||
(chmod hs-preserve-mode-db-directory hs-preserve-mode-db-directory-mode))
|
||||
|
||||
(defun hs-preserve-mode--filter-overlays (overlays)
|
||||
"Filer OVERYLAYS, a list of overlays, into a list of lists.
|
||||
This passes OVERLAYS thought `hs-preserve-mode-filter-functions'."
|
||||
(cl-loop for ov in overlays
|
||||
for props = (run-hook-with-args-until-success
|
||||
'hs-preserve-mode-filter-functions ov)
|
||||
when props
|
||||
collect (append
|
||||
(list (overlay-start ov)
|
||||
(overlay-end ov))
|
||||
(if (eq props t)
|
||||
(overlay-properties ov)
|
||||
props))))
|
||||
|
||||
(defun hs-preserve-mode--format-db (overlays printcharfun &optional no-newline)
|
||||
"Format the list of overlays OVERLAYS into a database.
|
||||
Write the DB to PRINTCHARFUN, which is the same as `prin1`. With NO-NEWLINE,
|
||||
don't print newlines between the entries.
|
||||
|
||||
Return the number of overlays that were actually printed."
|
||||
(let ((print-length nil)
|
||||
(print-level nil)
|
||||
(ov-props (hs-preserve-mode--filter-overlays overlays))
|
||||
(count 0))
|
||||
(dolist (ov ov-props count)
|
||||
(cl-incf count)
|
||||
(prin1 ov printcharfun)
|
||||
(unless no-newline
|
||||
(terpri printcharfun)))))
|
||||
|
||||
(defun hs-preserve-mode--write-db-file (&optional db-path)
|
||||
"Write a database file for the current buffer.
|
||||
If non-nil, write the DB to DB-PATH."
|
||||
(let ((bfn buffer-file-name)
|
||||
(overlays (without-restriction
|
||||
(car (overlay-lists))))
|
||||
(real-db-path (or db-path (hs-preserve-mode--db-file-path))))
|
||||
(with-temp-buffer
|
||||
(insert
|
||||
(format
|
||||
";; hs-preserve-mode.el database for %s -*- mode: lisp-data -*-\n" bfn))
|
||||
(let ((inhibit-message (or inhibit-message
|
||||
hs-preserve-mode-silent-db-writes))
|
||||
(message-log-max (and (booleanp hs-preserve-mode-silent-db-writes)
|
||||
message-log-max))
|
||||
(num-printed (hs-preserve-mode--format-db overlays
|
||||
(current-buffer))))
|
||||
(if (zerop num-printed)
|
||||
(prog1 (delete-file real-db-path)
|
||||
(message "Deleted %s" real-db-path))
|
||||
(hs-preserve-mode--ensure-db-directory)
|
||||
(write-region nil nil real-db-path))))))
|
||||
|
||||
(defun hs-preserve-mode--read-db (db-path)
|
||||
"Read the DB file DB-PATH and return the entries in it.
|
||||
The entries are returned as (START END [KEY VALUE ...])."
|
||||
(with-temp-buffer
|
||||
(insert-file-contents db-path)
|
||||
(let (out)
|
||||
(condition-case nil
|
||||
(cl-loop for ent = (read (current-buffer))
|
||||
while ent
|
||||
do (push ent out))
|
||||
(end-of-file out)))))
|
||||
|
||||
(defun hs-preserve-mode--load-db-file (&optional db-path)
|
||||
"Load a database file into the current buffer.
|
||||
This loads the current buffers database (or DB-PATH if it is non-nil) and
|
||||
creates overlays for each entry in the database."
|
||||
(let ((real-db-path (or db-path (hs-preserve-mode--db-file-path))))
|
||||
(cl-loop for (start end . props) in (hs-preserve-mode--read-db real-db-path)
|
||||
for ov = (make-overlay start end)
|
||||
do (cl-loop for (key val) on props by #'cddr
|
||||
do (overlay-put ov key val)))))
|
||||
|
||||
(defun hs-preserve-mode--db-invalid-p (&optional db-path)
|
||||
"Return non-nil if the database file is invalid.
|
||||
DB-PATH is the database to check against. The current buffer's modification
|
||||
time is checked against the databases modification time.
|
||||
- If the database and buffer both exist and the database is newer, return nil
|
||||
- If a file access error occurs (e.g. file does not exist), return \\=error
|
||||
- If the database is outdated, return \\=outdated
|
||||
- If the buffer is modified, return \\=modified"
|
||||
(condition-case nil
|
||||
(cond
|
||||
((buffer-modified-p) 'modified)
|
||||
((hs-preserve-mode--more-recently-modified-p
|
||||
buffer-file-name (or db-path (hs-preserve-mode--db-file-path)))
|
||||
'outdated))
|
||||
(file-error 'error)))
|
||||
|
||||
;;;###autoload
|
||||
(defun hs-preserve-mode-clear-file (&optional all no-confirm)
|
||||
"Clear the fold database for the current file.
|
||||
If ALL, clear the fold database for all files. ALL is true interactively with a
|
||||
prefix argument. With NO-CONFIRM, don't ask before clearing."
|
||||
(interactive "P\\ni")
|
||||
(if all
|
||||
(when (or no-confirm (yes-or-no-p "Really delete all fold databases? "))
|
||||
(delete-directory hs-preserve-mode-db-directory t))
|
||||
(delete-file (hs-preserve-mode--db-file-path))))
|
||||
|
||||
(defvar-local hs-preserve-mode--need-save-db nil
|
||||
"Flag variable to determine if we need save the DB in `post-command-hook'.
|
||||
This is set from the hooks setup with `hs-preserve-mode--setup-hooks'.")
|
||||
|
||||
(defun hs-preserve-mode--unconditional-hook ()
|
||||
"Set `hs-preserve-mode--need-save-db' to t."
|
||||
(setq hs-preserve-mode--need-save-db t))
|
||||
|
||||
(defun hs-preserve-mode--if-modified-hook ()
|
||||
"Set `hs-preserve-mode--need-save-db' to t if \\=(buffer-modified-p)."
|
||||
(when (buffer-modified-p)
|
||||
(setq hs-preserve-mode--need-save-db t)))
|
||||
|
||||
(defun hs-preserve-mode--unless-modified-hook ()
|
||||
"Set `hs-preserve-mode--need-save-db' to t unless \\=(buffer-modified-p)."
|
||||
(unless (buffer-modified-p)
|
||||
(setq hs-preserve-mode--need-save-db t)))
|
||||
|
||||
(defun hs-preserve-mode--post-command-hook ()
|
||||
"Maybe save the fold database from `post-command-hook'."
|
||||
(condition-case-unless-debug e
|
||||
(when hs-preserve-mode--need-save-db
|
||||
(setq hs-preserve-mode--need-save-db nil)
|
||||
(hs-preserve-mode--write-db-file))
|
||||
(file-error (message "`hs-preserve-mode' error: %s" e))))
|
||||
|
||||
(defvar-local hs-preserve-mode--setup-hooks-cache nil
|
||||
"List of hooks previously setup with `hs-preserve-mode--setup-hooks'.
|
||||
Used during tear-down of the mode.")
|
||||
|
||||
(defun hs-preserve-mode--setup-hooks (&optional teardown)
|
||||
"Setup hooks according to `hs-preserve-mode-trigger-hooks'.
|
||||
With TEARDOWN, instead remove previously setup hooks."
|
||||
(cl-flet ((add-or-remove-hook (hook fun)
|
||||
(if teardown
|
||||
(remove-hook hook fun t)
|
||||
(add-hook hook fun nil t))))
|
||||
(add-or-remove-hook 'post-command-hook
|
||||
#'hs-preserve-mode--post-command-hook)
|
||||
(dolist (ent (if teardown
|
||||
hs-preserve-mode--setup-hooks-cache
|
||||
hs-preserve-mode-trigger-hooks))
|
||||
(cond
|
||||
((atom ent)
|
||||
(add-or-remove-hook ent #'hs-preserve-mode--unconditional-hook))
|
||||
((cdr ent)
|
||||
(add-or-remove-hook (car ent) #'hs-preserve-mode--if-modified-hook))
|
||||
(t
|
||||
(add-or-remove-hook (car ent) #'hs-preserve-mode--unless-modified-hook))))
|
||||
(setq hs-preserve-mode--setup-hooks-cache hs-preserve-mode-trigger-hooks)))
|
||||
|
||||
;;;###autoload
|
||||
(define-minor-mode hs-preserve-mode
|
||||
"Minor mode to preserve `hs-minor-mode' folds.
|
||||
|
||||
`hs-preserve-mode-trigger-hooks' is processed after `hs-preserve-mode-hook', so
|
||||
buffer-local changes in hook functions will be reflected."
|
||||
:lighter "Hs-Preserve"
|
||||
:after-hook (hs-preserve-mode--setup-hooks (not hs-preserve-mode)))
|
||||
|
||||
;;;###autoload
|
||||
(defun hs-preserve-mode-restore-folds ()
|
||||
"Restore previous folds if the database is valid.
|
||||
If it is invalid, print a message explaining why and do nothing."
|
||||
(interactive)
|
||||
(with-demoted-errors "`hs-preserve-mode' error: %s"
|
||||
(let* ((db-path (hs-preserve-mode--db-file-path))
|
||||
(status (hs-preserve-mode--db-invalid-p db-path)))
|
||||
(cond
|
||||
((eq status 'outdated)
|
||||
(message "`hs-preserve-mode' error: Database outdated, not loading..."))
|
||||
((eq status 'modified)
|
||||
(message "`hs-preserve-mode' error: Buffer modified, not loading..."))
|
||||
((not status)
|
||||
(hs-preserve-mode--load-db-file db-path))))))
|
||||
|
||||
(provide 'hs-preserve-mode)
|
||||
;;; hs-preserve-mode.el ends here
|
||||
@@ -1690,6 +1690,15 @@ With PROJECT, give diagnostics for all buffers in the current project."
|
||||
:config
|
||||
(add-hook 'xref-backend-functions #'dumb-jump-xref-activate))
|
||||
|
||||
;; code folding
|
||||
(use-package hideshow
|
||||
:hook (prog-mode . hs-minor-mode))
|
||||
;; preserve folds
|
||||
(use-package hs-preserve-mode
|
||||
:ensure nil
|
||||
:hook ((hs-minor-mode . hs-preserve-mode)
|
||||
(hs-minor-mode . hs-preserve-mode-restore-folds)))
|
||||
|
||||
;; yasnippet
|
||||
(use-package yasnippet
|
||||
:demand t
|
||||
|
||||
Reference in New Issue
Block a user