279 lines
12 KiB
EmacsLisp
279 lines
12 KiB
EmacsLisp
;;; 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
|