;;; 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."
  (when (or path buffer-file-name)
    (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)
  (when buffer-file-name
    (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