;;; treemacs.el --- A tree style file viewer package -*- lexical-binding: t -*-

;; Copyright (C) 2024 Alexander Miller

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; General purpose macros, and those used in, but defined outside of
;; treemacs-core-utils.el are put here, to prevent using them before
;; their definition, hopefully preventing issues like #97.

;;; Code:

(require 'dash)
(require 's)
(require 'pcase)

(eval-when-compile
  (require 'cl-lib)
  (require 'gv))

(declare-function treemacs--scope-store "treemacs-scope")

(defmacro treemacs-import-functions-from (file &rest functions)
  "Import FILE's FUNCTIONS.
Creates a list of `declare-function' statements."
  (declare (indent 1))
  (let ((imports (--map (list 'declare-function it file) functions)))
    `(progn ,@imports)))

(defmacro treemacs-static-assert (predicate error-msg &rest error-args)
  "Assert for macros that triggers at expansion time.
Tests PREDICATE and, if it evaluates to nil, throws an error with ERROR-MSG and
ERROR-ARGS.  Basically the same thing as `cl-assert', but does not (seem to)
interfere with auto-completion."
  (declare (indent 1))
  `(unless ,predicate
     (error (apply #'format
                   (concat "[Treemacs] " ,error-msg)
                   (list ,@error-args)))))

(defmacro treemacs-with-writable-buffer (&rest body)
  "Temporarily turn off read-only mode to execute BODY."
  (declare (debug t))
  `(let (buffer-read-only)
     ,@body))

(defmacro treemacs-safe-button-get (button &rest properties)
  "Safely extract BUTTON's PROPERTIES.

Using `button-get' on a button located in a buffer that is not the current
buffer does not work, so this function will run the property extraction from
inside BUTTON's buffer."
  `(with-current-buffer (marker-buffer ,button)
     ,(if (= 1 (length properties))
           `(treemacs-button-get ,button ,(car properties))
         `(--map (treemacs-button-get ,button it) ,properties))))

(defmacro treemacs-with-button-buffer (btn &rest body)
  "Use BTN's buffer to execute BODY.
Required for button interactions (like `treemacs-button-get') that do not work
when called from another buffer than the one the button resides in and
`treemacs-safe-button-get' is not enough."
  (declare (indent 1)
           (debug (form body)))
  `(with-current-buffer (marker-buffer ,btn)
    ,@body))

(defmacro treemacs-unless-let (var-val &rest forms)
  "Same as `-if-let-', but the negative case is handled in the first form.
Delegates VAR-VAL and the given FORMS to `-if-let-'."
  (declare (debug ((sexp form) body))
           (indent 2))
  (let ((then (cdr forms))
        (else (car forms)))
    `(-if-let ,var-val (progn ,@then) ,else)))

(defmacro treemacs-with-current-button (error-msg &rest body)
  "Execute an action with the current button bound to \\='current-btn'.
Log ERROR-MSG if no button is selected, otherwise run BODY."
  (declare (debug (form body)))
  `(-if-let (current-btn (treemacs-current-button))
       (progn ,@body)
     (treemacs-pulse-on-failure ,error-msg)))

(defmacro treemacs-without-following (&rest body)
  "Execute BODY with `treemacs--ready-to-follow' set to nil."
  (declare (debug t))
  `(let ((treemacs--ready-to-follow nil))
     ;; ignore because not every module using this macro requires follow-mode.el
     (ignore treemacs--ready-to-follow)
     ,@body))

(cl-defmacro treemacs-do-for-button-state
    (&key no-error
          fallback
          on-root-node-open
          on-root-node-closed
          on-file-node-open
          on-file-node-closed
          on-dir-node-open
          on-dir-node-closed
          on-tag-node-open
          on-tag-node-closed
          on-tag-node-leaf
          on-nil)
"Building block macro to execute a form based on the current node state.
Will bind to current button to \\='btn' for the execution of the action forms.
When NO-ERROR is non-nil no error will be thrown if no match for the button
state is achieved.  A general FALLBACK can also be used instead of NO-ERROR.  In
that case the unknown state will be bound as `state' in the FALLBACK form.

Otherwise either one of ON-ROOT-NODE-OPEN, ON-ROOT-NODE-CLOSED,
ON-FILE-NODE-OPEN, ON-FILE-NODE-CLOSED, ON-DIR-NODE-OPEN, ON-DIR-NODE-CLOSED,
ON-TAG-NODE-OPEN, ON-TAG-NODE-CLOSED, ON-TAG-NODE-LEAF or ON-NIL will be
executed."
  (declare (debug (&rest [sexp form])))

  (treemacs-static-assert (or (null no-error) (null fallback))
    "no-error and fallback arguments are mutually exclusive.")

  `(-if-let (btn (treemacs-current-button))
       (pcase (treemacs-button-get btn :state)
         ,@(when on-root-node-open
             `((`root-node-open
                ,on-root-node-open)))
         ,@(when on-root-node-closed
             `((`root-node-closed
                ,on-root-node-closed)))
         ,@(when on-file-node-open
             `((`file-node-open
                ,on-file-node-open)))
         ,@(when on-file-node-closed
             `((`file-node-closed
                ,on-file-node-closed)))
         ,@(when on-dir-node-open
             `((`dir-node-open
                ,on-dir-node-open)))
         ,@(when on-dir-node-closed
             `((`dir-node-closed
                ,on-dir-node-closed)))
         ,@(when on-tag-node-open
             `((`tag-node-open
                ,on-tag-node-open)))
         ,@(when on-tag-node-closed
             `((`tag-node-closed
                ,on-tag-node-closed)))
         ,@(when on-tag-node-leaf
             `((`tag-node
                ,on-tag-node-leaf)))
         ,@(when fallback
             `((state
                (ignore state)
                ,fallback)))
         ,@(unless (or fallback no-error)
             `((state (error "[Treemacs] Unexpected button state %s" state)))))
     ,on-nil))

(cl-defmacro treemacs--execute-button-action
    (&key no-match-explanation
          window
          split-function
          ensure-window-split
          dir-action
          file-action
          tag-section-action
          tag-action
          window-arg)
  "Infrastructure macro for setting up actions on different button states.

Fetches the currently selected button and verifies it's in the correct state
based on the given state actions.

If it isn't it will log NO-MATCH-EXPLANATION, if it is it selects WINDOW (or
`next-window' if none is given) and splits it with SPLIT-FUNCTION if given.

If ENSURE-WINDOW-SPLIT is non-nil treemacs will vertically split the window if
treemacs is the only window to make sure a buffer is opened next to it, not
under or below it.

DIR-ACTION, FILE-ACTION, TAG-SECTION-ACTION and TAG-ACTION are inserted into a
`pcase' statement matching the buttons state.  Project root nodes are treated
the same common directory nodes.

WINDOW-ARG determines whether the treemacs windows should remain selected,
\(single prefix arg), or deleted (double prefix arg)."
  (declare (debug (&rest [sexp form])))
  (let ((valid-states (list)))
    (when dir-action
      (push 'root-node-open valid-states)
      (push 'root-node-closed valid-states)
      (push 'dir-node-open valid-states)
      (push 'dir-node-closed valid-states))
    (when file-action
      (push 'file-node-open valid-states)
      (push 'file-node-closed valid-states))
    (when tag-section-action
      (push 'tag-node-open valid-states)
      (push 'tag-node-closed valid-states))
    (when tag-action
      (push 'tag-node valid-states))
    `(-when-let (btn (treemacs-current-button))
       (treemacs-without-following
        (let* ((state (treemacs-button-get btn :state))
               (current-window (selected-window)))
          (if (and (not (memq state ',valid-states))
                   (not (get state :treemacs-visit-action)))
              (treemacs-pulse-on-failure "%s" ,no-match-explanation)
            (progn
              ,@(if ensure-window-split
                    `((when (one-window-p)
                        (save-selected-window
                          (split-window nil nil (if (eq 'left treemacs-position) 'right 'left))))))
              (select-window (or ,window (next-window (selected-window) nil nil)))
              ,@(if split-function
                    `((funcall ,split-function)
                      (other-window 1)))
              ;; Return the result of the action
              (prog1 (pcase state
                       ,@(when dir-action
                           `(((or `dir-node-open `dir-node-closed `root-node-open `root-node-closed)
                              ,dir-action)))
                       ,@(when file-action
                           `(((or `file-node-open `file-node-closed)
                              ,file-action)))
                       ,@(when tag-section-action
                           `(((or `tag-node-open `tag-node-closed)
                              ,tag-section-action)))
                       ,@(when tag-action
                           `((`tag-node
                              ,tag-action)))
                       (_
                        (-if-let (visit-action (get state :treemacs-visit-action))
                            (funcall visit-action btn)
                          (error "No match achieved even though button's state %s was part of the set of valid states %s"
                                 state ',valid-states))))
                (pcase ,window-arg
                  ('(4) (select-window current-window))
                  ('(16) (delete-window current-window)))))))))))

;; TODO(2021/08/28): RM
(defmacro treemacs--without-filewatch (&rest body)
  "Run BODY without triggering the filewatch callback.
Required for manual interactions with the file system (like deletion), otherwise
the on-delete code will run twice."
  (declare (debug t))
  `(cl-flet (((symbol-function 'treemacs--filewatch-callback) (symbol-function 'ignore)))
     ,@body))

(defmacro treemacs-save-position (main-form &rest final-form)
  "Execute MAIN-FORM without switching position.
Finally execute FINAL-FORM after the code to restore the position has run.

This macro is meant for cases where a simple `save-excursion' will not do, like
a refresh, which can potentially change the entire buffer layout.  In practice
this means attempt first to keep point on the same file/tag, and if that does
not work keep it on the same line."
  (declare (debug (form body)))
  `(treemacs-without-following
    (declare-function treemacs--current-screen-line "treemacs-rendering")
    (let* ((curr-btn       (treemacs-current-button))
           (curr-point     (point-marker))
           (next-path      (-some-> curr-btn (treemacs--next-non-child-button) (button-get :path)))
           (prev-path      (-some-> curr-btn (treemacs--prev-non-child-button) (button-get :path)))
           (curr-node-path (-some-> curr-btn (treemacs-button-get :path)))
           (curr-state     (-some-> curr-btn (treemacs-button-get :state)))
           (collapse       (-some-> curr-btn (treemacs-button-get :collapsed)))
           (curr-file      (if collapse (treemacs-button-get curr-btn :key) (-some-> curr-btn (treemacs--nearest-path))))
           (curr-window    (get-buffer-window (current-buffer)))
           (curr-win-line  (when curr-window
                             (with-selected-window curr-window
                               (treemacs--current-screen-line)))))
      ,main-form
      ;; try to stay at the same file/tag
      ;; if the tag no longer exists move to the tag's owning file node
      (pcase curr-state
        ((or 'root-node-open 'root-node-closed)
         ;; root nodes are always visible even if deleted.
         (treemacs-goto-file-node curr-file))
        ((or 'dir-node-open 'dir-node-closed 'file-node-open 'file-node-closed)
         ;; stay on the same file
         (if (and (treemacs-is-path-visible? curr-file)
                  (or treemacs-show-hidden-files
                      (not (s-matches? treemacs-dotfiles-regex (treemacs--filename curr-file)))))
             (treemacs-goto-file-node curr-file)
           ;; file we were on is no longer visible
           ;; try dodging to our immediate neighbours, if they are no longer visible either
           ;; keep going up
           (cl-labels
               ((can-move-to (it) (and (treemacs-is-path-visible? it)
                                       (or treemacs-show-hidden-files
                                           (not (s-matches? treemacs-dotfiles-regex (treemacs--filename it)))))))
             (cond
              ((and next-path (can-move-to next-path))
               (treemacs-goto-file-node next-path))
              ((and prev-path (can-move-to prev-path))
               (treemacs-goto-file-node prev-path))
              (t
               (-let [detour (treemacs--parent curr-file)]
                 (while (not (can-move-to detour))
                   (setf detour (treemacs--parent detour)))
                 (treemacs-goto-file-node detour)))))))
        ((or 'tag-node-open 'tag-node-closed 'tag-node)
         (treemacs-goto-node curr-node-path))
        ((pred null)
         (goto-char curr-point))
        (_
         ;; point is on a custom node
         (cond
          ((treemacs-is-path-visible? curr-node-path)
           (treemacs-goto-extension-node curr-node-path))
          ((and next-path (treemacs-is-path-visible? next-path))
           (treemacs-goto-extension-node next-path))
          ((and prev-path (treemacs-is-path-visible? prev-path))
           (treemacs-goto-extension-node prev-path))
          (t
           (-let [detour (treemacs--parent curr-file)]
             (while (not (treemacs-is-path-visible? detour))
               (setf detour (treemacs--parent detour)))
             (treemacs-goto-extension-node detour))))))
      (treemacs--evade-image)
      (when (get-text-property (point) 'invisible)
        (goto-char (or
                    (next-single-property-change (point) 'invisible)
                    (point-min))))
      (when curr-win-line
        (-let [buffer-point (point)]
          (with-selected-window curr-window
            ;; recenter starts counting at 0
            (-let [scroll-margin 0]
              (recenter (1- curr-win-line)))
            (set-window-point (selected-window) buffer-point))))
      ,@final-form)))

(defmacro treemacs-with-workspace (workspace &rest body)
  "Use WORKSPACE as the current workspace when running BODY.
Specifically this means that calls to `treemacs-current-workspace' will return
WORKSPACE and if no workspace has been set for the current scope yet it will not
be set either."
  (declare (indent 1) (debug (form body)))
  `(let ((treemacs-override-workspace ,workspace))
     (ignore treemacs-override-workspace)
     ,@body))

(defmacro treemacs-run-in-every-buffer (&rest body)
  "Run BODY once locally in every treemacs buffer.
Only includes treemacs file tree buffers, not extensions.
Sets `treemacs-override-workspace' so calls to `treemacs-current-workspace'
return the workspace of the active treemacs buffer."
  (declare (debug t))
  `(pcase-dolist (`(,_ . ,shelf) (treemacs--scope-store))
     (let ((buffer (treemacs-scope-shelf->buffer shelf))
           (workspace (treemacs-scope-shelf->workspace shelf)))
       (when (buffer-live-p buffer)
         (treemacs-with-workspace workspace
           (with-current-buffer buffer
             ,@body))))))

(defmacro treemacs-run-in-all-derived-buffers (&rest body)
  "Run BODY once locally in every treemacs buffer.
Includes *all* treemacs-mode-derived buffers, including extensions."
  (declare (debug t))
  `(dolist (buffer (buffer-list))
     (when (buffer-local-value 'treemacs--in-this-buffer buffer)
       (with-current-buffer buffer
         ,@body))))

(defmacro treemacs-only-during-init (&rest body)
  "Run BODY only when treemacs has not yet been loaded.
Specifically only run it when (featurep \\='treemacs) returns nil."
  (declare (debug t))
  `(unless (featurep 'treemacs)
     ,@body))

(defmacro treemacs--maphash (table names &rest body)
  "Iterate over entries of TABLE with NAMES in BODY.
Entry variables will bound based on NAMES which is a list of two elements."
  (declare (debug (sexp sexp body))
           (indent 2))
  (let ((key-name (car names))
        (val-name (cadr names)))
    `(maphash
      (lambda (,key-name ,val-name) ,@body)
      ,table)))

(defmacro treemacs-error-return (error-msg &rest msg-args)
  "Interactive early return failure from `treemacs-block'.
Will also pass ERROR-MSG and MSG-ARGS to `treemacs-pulse-on-failure'."
  (declare (indent 1) (debug (form body)))
  `(cl-return-from __body__
     (treemacs-pulse-on-failure ,error-msg ,@msg-args)))

(defmacro treemacs-error-return-if (predicate error-msg &rest msg-args)
  "Interactive early return from `treemacs-block'.
Checks if PREDICATE returns a non-nil value, and will pass also ERROR-MSG and
MSG-ARGS to `treemacs-pulse-on-failure'."
  (declare (indent 1) (debug (form sexp body)))
  `(when ,predicate
     (cl-return-from __body__
       (treemacs-pulse-on-failure ,error-msg ,@msg-args))))

(defmacro treemacs-return (ret)
  "Early return from `treemacs-block', returning RET."
  (declare (debug t))
  `(cl-return-from __body__ ,ret))

(defmacro treemacs-return-if (predicate &optional ret)
  "Early return from `treemacs-block'.
When PREDICATE returns non-nil RET will be returned."
  (declare (indent 1) (debug (form sexp)))
  `(when ,predicate
     (cl-return-from __body__ ,ret)))

(cl-defmacro treemacs-first-child-node-where (btn &rest predicate)
  "Among the *direct* children of BTN find the first child matching PREDICATE.
For the PREDICATE call the button being checked is bound as \\='child-btn'."
  (declare (indent 1) (debug (sexp body)))
  `(cl-block __search__
     (let* ((child-btn (next-button (treemacs-button-end ,btn) t))
            (depth (when child-btn (treemacs-button-get child-btn :depth))))
       (when (and child-btn
                  (equal (treemacs-button-get child-btn :parent) ,btn))
         (if (progn ,@predicate)
             (cl-return-from __search__ child-btn)
           (while child-btn
             (setq child-btn (next-button (treemacs-button-end child-btn)))
             (when child-btn
               (-let [child-depth (treemacs-button-get child-btn :depth)]
                 (cond
                  ((= depth child-depth)
                   (when (progn ,@predicate) (cl-return-from __search__ child-btn)) )
                  ((> depth child-depth)
                   (cl-return-from __search__ nil)))))))))))

(defmacro treemacs-block (&rest forms)
  "Put FORMS in a `cl-block' named '__body__'.
This pattern is oftentimes used in treemacs, see also `treemacs-return-if',
`treemacs-return', `treemacs-error-return' and `treemacs-error-return-if'"
  (declare (debug t))
  `(cl-block __body__ ,@forms))

(defmacro treemacs-is-path (left op &optional right)
  "Readable utility macro for various path predicates.
LEFT is a file path, OP is the operator and RIGHT is either a path, project, or
workspace.  OP can be one of the following:

 * `:same-as' will check for string equality.
 * `:in' will check will check whether LEFT is a child or the same as RIGHT.
 * `:directly-in' will check will check whether LEFT is *direct* child of RIGHT.
 * `:parent-of' will check whether LEFT is a parent of, and not equal to, RIGHT.
 * `:in-project' will check whether LEFT is part of the project RIGHT.
 * `:in-workspace' will check whether LEFT is part of the workspace RIGHT and
   return the appropriate project when it is.  If RIGHT is not given it will
   default to calling `treemacs-current-workspace'.

LEFT and RIGHT are expected to be in treemacs canonical file path format (see
also `treemacs-canonical-path').

Even if LEFT or RIGHT should be a form and not a variable it is guaranteed that
they will be evaluated only once."
  (declare (debug (&rest form)))
  (treemacs-static-assert (memq op '(:same-as :in :directly-in :parent-of :in-project :in-workspace))
    "Invalid treemacs-is-path operator: `%s'" op)
  (treemacs-static-assert (or (eq op :in-workspace) right)
    "Right-side argument is required")
  (macroexp-let2* nil
      ((left left)
       (right right))
    (pcase op
      (:same-as
       `(string= ,left ,right))
      (:in
       `(or (string= ,left ,right)
            (s-starts-with? (treemacs--add-trailing-slash ,right) ,left)))
      (:directly-in
       `(let ((l (length ,right)))
          (and (> (length ,left) l)
               (string= (treemacs--filename ,left) (substring ,left (1+ l)))
               (string-prefix-p ,right ,left))))
      (:parent-of
       `(and (s-starts-with? (treemacs--add-trailing-slash ,left) ,right)
             (not (string= ,left ,right))))
      (:in-project
       `(treemacs-is-path ,left :in (treemacs-project->path ,right)))
      (:in-workspace
       (-let [ws (or right '(treemacs-current-workspace))]
         `(--first (treemacs-is-path ,left :in-project it)
                   (treemacs-workspace->projects ,ws)))))))

(cl-defmacro treemacs-with-path (path &key file-action extension-action no-match-action)
  "Execute an action depending on the type of PATH.

FILE-ACTION is the action to perform when PATH is a regular file node.
EXTENSION-ACTION is performed on extension-created nodes.

If none of the path types matches, NO-MATCH-ACTION is executed."
  (declare (indent 1))
  (let ((path-symbol (make-symbol "path")))
    `(let ((,path-symbol ,path))
       (cond
        ,@(when file-action
            `(((stringp ,path-symbol) ,file-action)))
        ,@(when extension-action
            `(((or (symbolp ,path)
                   (symbolp (car ,path))
                   (stringp (car ,path)))
               ,extension-action)))
        (t
         ,(if no-match-action
              no-match-action
            `(error "Path type did not match: %S" ,path-symbol)))))))


(defmacro treemacs-with-toggle (&rest body)
  "Building block helper macro.
If treemacs is currently visible it will be hidden, if it is not visible, or no
treemacs buffer exists at all, BODY will be executed."
  `(--if-let (treemacs-get-local-window)
       (delete-window it)
     ,@body))

(defmacro treemacs-with-ignored-errors (ignored-errors &rest body)
  "Given list of specifically IGNORED-ERRORS evaluate BODY.

IGNORED-ERRORS is a list of errors to ignore.  Each element is a list whose car
is the error's type, and second item is a regex to match against error messages.
If any of the IGNORED-ERRORS matches, the error is suppressed and nil returned."
  (let ((err (make-symbol "err")))
    `(condition-case-unless-debug ,err
         ,(macroexp-progn body)
       ,@(mapcar
          (lambda (ignore-spec)
            `(,(car ignore-spec)
              (unless (string-match-p ,(nth 1 ignore-spec) (error-message-string ,err))
                (signal (car ,err) (cdr ,err)))))
          ignored-errors))))

(defmacro treemacs-debounce (guard delay &rest body)
  "Debounce a function call.
Based on a timer GUARD variable run function with the given DELAY and BODY."
  (declare (indent 2))
  `(unless ,guard
     (setf ,guard
           (run-with-idle-timer
            ,delay nil
            (lambda ()
              (unwind-protect
                  (progn ,@body)
                (setf ,guard nil)))))))

(defmacro treemacs-without-recenter (&rest body)
  "Run BODY without the usual recentering for expanded nodes.
Specifically `treemacs--no-recenter' will be set to \\='t' so that
`treemacs--maybe-recenter' will have no effect during non-interactive updates
triggered by e.g. filewatch-mode."
  (declare (debug t))
  `(let ((treemacs--no-recenter t))
     ,@body))

(provide 'treemacs-macros)

;;; treemacs-macros.el ends here
