path: root/lisp/acdw-funs.el

;;; acdw-funs.el --- extra functions -*- lexical-binding: t -*-


;;; Cribs from CRUX --- Advice
;; https://github.com/bbatsov/crux

;; All of these should go `:before' the function they're advising
(defun advise-region-or-buffer (&rest _)
  "`:before' advice to work on the active region or whole buffer.
See also `with-region-or-buffer'."
  (interactive (if mark-active
                   (list (region-beginning) (region-end))
                 (list (point-min) (point-max)))))

(defun advise-region-or-line (&rest _)
  "`:before' advice to work on the active region or whole line.
See also `with-region-or-line'."
  (interactive (if mark-active
                   (list (region-beginning) (region-end))
                 (list (line-beginning-position) (line-end-position)))))

(defun advise-region-or-to-eol (&rest _)
  "`:before' advice to work on the active region or to end of line.
See also `with-region-or-to-eol'."
  (INTERACTIVE (if mark-active
                   (list (region-beginning) (region-end))
                 (list (point) (line-end-position)))))


;;; Other functions and whatnot

(defun delete2 (list &rest elems)
  "Delete each element of ELEMS, and the next item, from LIST."
  (let ((r nil))
    (while (consp list)
      (if (member (car list) elems)
          (setf list (cdr list))
        (setf r (cons (car list) r)))
      (setf list (cdr list)))
    (reverse r)))

(unless (fboundp 'ensure-list)
  (defun ensure-list (object)
    "Return OBJECT as a list.
If OBJECT is already a list, return OBJECT itself.  If it's
not a list, return a one-element list containing OBJECT."
    (if (listp object)
        object
      (list object))))

(defun +require (&rest features)
  "Require FEATURES, plus my extras.
Each feature can be an atom (the feature name) or a list of the form
(FEATURE &optional FILENAME NOERROR), which is passed directly to
`require'.  My extras are in lisp/ and named +FEATURE, so this
function will `require' them too---but not error if they don't
exist."
  (dolist (feat features)
    (apply #'require (ensure-list feat))
    (require (intern (format "+%s" feat)) nil :noerror)))

;;; Improvements to default functions

(defun +save-buffers-kill-terminal (arg)
              "Delete the current frame, or quit Emacs.
This function is my customization of `save-buffers-kill-terminal'."
              (interactive "P")
              (cond (arg (delete-frame nil :force))
                    ((= 1 (length (frame-list)))
                     (and (yes-or-no-p "Kill emacs? ")
                          (save-buffers-kill-emacs t)))
                    (:else (delete-frame))))

(defun really-quit-emacs (arg)
              "Really, actually quit Emacs."
              (interactive "P")
              (cond (arg (save-buffers-kill-emacs t))
                    (:else (save-buffers-kill-terminal t))))

(defun +cycle-spacing (&optional n)
  ;; `cycle-spacing' is wildly different in 29.1 over 28.
  "Negate N argument on `cycle-spacing'.
That is, with a positive N, deletes newlines as well, leaving -N
spaces.  If N is negative, it will not delete newlines and leave
N spaces."
            (interactive "*p")
            (cycle-spacing (- n)))

(defun delete-window|bury-buffer ()
            "Delete the current window, or bury the current buffer.
If the current window is the only window, bury the buffer."
            (interactive)
            (condition-case e
                (delete-window)
              (t (bury-buffer))))

(defun other-window|switch-buffer (arg)
          "Call `other-window' or `switch-buffer' depending on windows.
When called with prefix ARG, unconditionally switch buffer."
          (interactive "P")
          (if (or arg (one-window-p))
              (switch-to-buffer (other-buffer) nil t)
            (other-window 1)))

(defun open-paragraph (&optional arg)
            "Open a paragraph after paragraph at point.
A paragraph is defined as continguous non-empty lines of text
surrounded by empty lines, so opening a paragraph means to make
three blank lines, then place the point on the second one.

Called with prefix ARG, open a paragraph before point."
            ;; TODO: Take an integer as ARG, allowing for skipping paragraphs up and down.
            (interactive "*P")
            ;; Go to next blank line.  This /isn't/ `end-of-paragraph-text' because
            ;; that's weird with org, and I'm guessing other modes too.
            (unless (looking-at "^$") (forward-line (if arg -1 +1)))
            (while (and (not (looking-at "^$"))
                        (= 0 (forward-line (if arg -1 +1)))))
            (newline)
            (when arg (newline) (forward-line -2))
            (delete-blank-lines)
            (newline 2)
            (previous-line))

(defun +initial-buffer ()
  (if (equal (get-buffer "*Messages*")
             (other-buffer))
      (get-buffer "*scratch*")
    (other-buffer)))

(defun open-paragraph (&optional arg)
            "Open a paragraph after paragraph at point.
A paragraph is defined as continguous non-empty lines of text
surrounded by empty lines, so opening a paragraph means to make
three blank lines, then place the point on the second one.

Called with prefix ARG, open a paragraph before point."
            ;; TODO: Take an integer as ARG, allowing for skipping paragraphs up and down.
            (interactive "*P")
            ;; Go to next blank line.  This /isn't/ `end-of-paragraph-text' because
            ;; that's weird with org, and I'm guessing other modes too.
            (unless (looking-at "^$") (forward-line (if arg -1 +1)))
            (while (and (not (looking-at "^$"))
                        (= 0 (forward-line (if arg -1 +1)))))
            (newline)
            (when arg (newline) (forward-line -2))
            (delete-blank-lines)
            (newline 2)
            (previous-line))

(defun create-missing-directories ()
  "Automatically create missing directories when finding a file."
  ;; https://emacsredux.com/blog/2022/06/12/auto-create-missing-directories/
  (let ((target-dir (file-name-directory buffer-file-name)))
    (unless (file-exists-p target-dir)
      (make-directory target-dir t))))

(defun +vc-off@remote ()
  (when (file-remote-p (buffer-file-name))
    (setq-local vc-handled-backends nil)))

(defun +auto-save-some-buffers (&rest _)
  "Quietly run `save-some-buffers'."
  (let ((inhibit-message t))
    (with-temp-message ""
      (save-some-buffers t))))

(defun comment-lines (str &optional comment-char)
  "Comment each line of STR.
Returns the new, commented, string.

If COMMENT-CHAR is missing or nil, use `comment-start'."
  (mapconcat (lambda (ln)
               (concat (or comment-char comment-start)
                       ln))
             (string-lines str)
             "\n"))

(defun clamp (value min max)
  "Clamp VALUE between MIN and MAX."
  (min max (max min value)))

(define-minor-mode truncate-lines-local-mode
  "Truncate lines locally in a buffer."
  :lighter " ..."
  :group 'display
  (setq-local truncate-lines truncate-lines-local-mode))

(defun mapc-buffers (func &optional predicate)
  "Map FUNC over buffers matching PREDICATE.
Both FUNC and PREDICATE will be executed with no arguments and in
the context of each buffer.

If PREDICATE is nil or not given, map FUNC over all buffers."
  (cl-loop for buf being the buffers
           do (with-current-buffer buf
                (when (and predicate
                           (funcall predicate))
                  (funcall func)))))

(defun mapc-buffers-modes (func &rest modes)
  "Map FUNC over buffers derived from MODES.
FUNC will be executed with no arguments and in the context of
each buffer."
  (mapc-buffers func
                (lambda ()
                  (apply #'derived-mode-p modes))))

(defun ++concat (func strings)
  "Concat STRINGS processed by FUNC.
Each of STRINGS can be a bare string or a list.  Strings are
passed through as-is, but lists are passed to FUNC first as
arguments.  Finally, all the resulting strings are `mapconcat'-ed
together.

As a special case, if `:separator' is the first of STRINGS, the
string following will be used as a separator.  Otherwise, a
newline will be used."
  (let (separator)
    (when (eq (car strings) :separator)
      (setq separator (cadr strings)
            strings (cddr strings)))
    (mapconcat (lambda (s)
                 (cond
                  ((listp s) (apply func s))
                  ((stringp s) s)
                  (t (user-error "Bad argument: %S" s))))
               strings
               (or separator "\n"))))

(defun nconcat (&rest strings)
  "Concat STRINGS separated by SEPARATOR.
If `:separator' is the first of STRINGS, the next string will be used to
separate the rest of STRINGS."
  (++concat #'concat strings))

(defun format-concat (&rest strings)
  "Concatenate formatted STRINGS.
Each of STRINGS can be a bare string or a list.  Bare strings are passed as-is
to `mapconcat' for concatenation and separation.  Lists, however, are passed to
`format' first.

If `:separator' is the first of STRINGS, the next string will be
used as a separator."
  (++concat #'format strings))

(defun choose-executable (&rest programs)
  "Return the first of PROGRAMS that exists in the system's $PATH."
  (seq-some #'executable-find programs))

;;; Update packages more better-er

(defun +package-update-all ()
  "Update all packages and vc packages."
  (interactive)
  (package-update-all)
  ;; WTF!
  (let ((package-archives-nil))
    (package-vc-update-all)))

(provide 'acdw-funs)
;;; acdw-funs.el ends here