path: root/lisp/acdw.el

;;; acdw.el --- various meta-whatevers -*- lexical-binding: t -*-

;;; Commentary:

;; What's that saying about how the hardest things in computer science
;; are naming and off-by-one errors?  Well, the naming one I know very
;; well.  I've been trying to figure out a good way to prefix my
;; bespoke functions, other stuff I found online, and various emacs
;; lisp detritus for quite some time (I reckon at over a year, as of
;; 2021-11-02).  Finally, I found the answer in the writings of Daniel
;; Mendler: I'll prefix everything with a `+' !

;; To that end, pretty much everything in lisp/ will have a filename
;; like "+org.el", except of course this file, and maybe a few
;; /actually original/ libraries I haven't had the wherewithal to
;; package out properly yet.

;; Is it perfect?  No.  Is it fine?  Yes.  Here it is.

;;; Code:

(require 'diary-lib)
(require 'solar)                        ; for +sunrise-sunset

;;; Define a directory and an expanding function

(defmacro +define-dir (name directory &optional docstring inhibit-mkdir)
  "Define a variable and function NAME expanding to DIRECTORY.
DOCSTRING is applied to the variable.  Ensure DIRECTORY exists in
the filesystem, unless INHIBIT-MKDIR is non-nil."
  (declare (indent 2)
           (doc-string 3))
  (unless inhibit-mkdir
    (make-directory (eval directory) :parents))
  `(progn
     (defvar ,name ,directory
       ,(concat docstring (when docstring "\n")
                "Defined by `/define-dir'."))
     (defun ,name (file &optional mkdir)
       ,(concat "Expand FILE relative to variable `" (symbol-name name) "'.\n"
                "If MKDIR is non-nil, the directory is created.\n"
                "Defined by `/define-dir'.")
       (let ((file-name (expand-file-name (convert-standard-filename file)
                                          ,name)))
         (when mkdir
           (make-directory (file-name-directory file-name) :parents))
         file-name))))

(defun +suppress-messages (oldfn &rest args) ; from pkal
  "Advice wrapper for suppressing `message'.
OLDFN is the wrapped function, that is passed the arguments
ARGS."
  (let ((msg (current-message)))
    (prog1
        (let ((inhibit-message t))
          (apply oldfn args))
      (when msg
        (message "%s" msg)))))

(defun +ensure-after-init (function)
  "Ensure FUNCTION runs after init, or now if already initialized.
If Emacs is already started, run FUNCTION.  Otherwise, add it to
`after-init-hook'.  FUNCTION is called with no arguments."
  (if after-init-time
      (funcall function)
    (add-hook 'after-init-hook function)))

(defmacro +with-ensure-after-init (&rest body)
  "Ensure BODY forms run after init.
Convenience macro wrapper around `+ensure-after-init'."
  (declare (indent 0) (debug (def-body)))
  `(+ensure-after-init (lambda () ,@body)))

(defun +remember-prefix-arg (p-arg P-arg)
  "Display prefix ARG, in \"p\" and \"P\" `interactive' types.
I keep forgetting how they differ."
  (interactive "p\nP")
  (message "p: %S	P: %S" p-arg P-arg))

(defmacro +defvar (var value &rest _)
  "Quick way to `setq' a variable from a `defvar' form."
  (declare (doc-string 3) (indent 2))
  `(setq ,var ,value))

(defmacro +with-message (message &rest body)
  "Execute BODY, with MESSAGE.
If body executes without errors, MESSAGE...Done will be displayed."
  (declare (indent 1))
  (let ((msg (gensym)))
    `(let ((,msg ,message))
       (condition-case e
           (progn (message "%s..." ,msg)
                  ,@body)
         (:success (message "%s...done" ,msg))
         (t (signal (car e) (cdr e)))))))

(defun +mapc-some-buffers (func &optional predicate)
  "Perform FUNC on all buffers satisfied by PREDICATE.
By default, act on all buffers.

Both PREDICATE and FUNC are called with no arguments, but within
a `with-current-buffer' form on the currently-active buffer.

As a special case, if PREDICATE is a list, it will be interpreted
as a list of major modes.  In this case, FUNC will only be called
on buffers derived from one of the modes in PREDICATE."
  (let ((pred (or predicate t)))
    (dolist (buf (buffer-list))
      (with-current-buffer buf
        (when (cond ((functionp pred)
                     (funcall pred))
                    ((listp pred)
                     (apply #'derived-mode-p pred))
                    (t pred))
          (funcall func))))))

;; https://github.com/cstby/emacs.d/blob/main/init.el#L67
(defun +clean-empty-lines (&optional begin end)
  "Remove duplicate empty lines from BEGIN to END.
Called interactively, this function acts on the region, if
active, or else the entire buffer."
  (interactive "*r")
  (unless (region-active-p)
    (setq begin (point-min)
          end (save-excursion
                (goto-char (point-max))
                (skip-chars-backward "\n[:space:]")
                (point))))
  (save-excursion
    (save-restriction
      (narrow-to-region begin end)
      (goto-char (point-min))
      (while (re-search-forward "\n\n\n+" nil :move)
        (replace-match "\n\n"))
      ;; Insert a newline at the end.
      (goto-char (point-max))
      (unless (or (buffer-narrowed-p)
                  (= (line-beginning-position) (line-end-position)))
        (insert "\n")))))

(defcustom +open-paragraph-ignore-modes '(special-mode lui-mode comint-mode)
  "Modes in which `+open-paragraph' makes no sense."
  :type '(repeat function))

(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")
  ;; TODO: add `+open-paragraph-ignore-modes'
  (unless (apply #'derived-mode-p +open-paragraph-ignore-modes)
    ;; 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 +split-window-then (&optional where arg)
  "Split the window into a new buffer.
With non-nil ARG (\\[universal-argument] interactively), don't
prompt for a buffer to switch to.  This function will split the
window using `split-window-sensibly', or open the new window in
the direction specified by WHERE.  WHERE is ignored when called
interactively; if you want specific splitting, use
`+split-window-right-then' or `+split-window-below-then'."
  (interactive "i\nP")
  ;; TODO: Canceling at the switching phase leaves the point in the other
  ;; window.  Ideally, the user would see this as one action, meaning a cancel
  ;; would return to the original window.
  (pcase where
    ;; These directions are 'backward' to the OG Emacs split-window commands,
    ;; because by default Emacs leaves the cursor in the original window.  Most
    ;; users probably expect a switch to the new window, at least I do.
    ((or 'right :right) (split-window-right) (other-window 1))
    ((or 'left :left) (split-window-right))
    ((or 'below :below) (split-window-below) (other-window 1))
    ((or 'above :above) (split-window-below))
    ((pred null)
     (or (split-window-sensibly)
         (if (< (window-height) (window-width))
             (split-window-below)
           (split-window-right)))
     (other-window 1))
    (_ (user-error "Unknown WHERE paramater: %s" where)))
  (unless arg
    (condition-case nil
        (call-interactively
         (pcase (read-char "(B)uffer or (F)ile?")
           (?b (if (fboundp #'consult-buffer)
                   #'consult-buffer
                 #'switch-to-buffer))
           (?f #'find-file)
           (_ #'ignore)))
      (quit (delete-window)))))

(defun +split-window-right-then (&optional arg)
  "Split window right, then prompt for a new buffer.
With optional ARG (\\[universal-argument]), just split."
  (interactive "P")
  (+split-window-then :right arg))

(defun +split-window-below-then (&optional arg)
  "Split window below, then prompt for a new buffer.
With optional ARG (\\[universal-argument]), just split."
  (interactive "P")
  (+split-window-then :below arg))

(defun +bytes (number unit)
  "Convert NUMBER UNITs to bytes.
UNIT can be one of :kb, :mb, :gb, :tb, :pb, :eb, :zb, :yb; :kib, :mib, :gib,
:tib, :pib, :eib, :zib, :yib."
  (* number (pcase unit
              ;; Base 10 units
              (:kb 1000)
              (:mb (* 1000 1000))
              (:gb (* 1000 1000 1000))
              (:tb (* 1000 1000 1000 1000))
              (:pb (* 1000 1000 1000 1000 1000))
              (:eb (* 1000 1000 1000 1000 1000 1000))
              (:zb (* 1000 1000 1000 1000 1000 1000 1000))
              (:yb (* 1000 1000 1000 1000 1000 1000 1000 1000))
              ;; Base 2 units
              (:kib 1024)
              (:mib (* 1024 1024))
              (:gib (* 1024 1024 1024))
              (:tib (* 1024 1024 1024 1024))
              (:pib (* 1024 1024 1024 1024 1024))
              (:eib (* 1024 1024 1024 1024 1024 1024))
              (:zib (* 1024 1024 1024 1024 1024 1024 1024))
              (:yib (* 1024 1024 1024 1024 1024 1024 1024 1024)))))

;;; Font lock TODO keywords

(defcustom font-lock-todo-keywords '("TODO" "XXX" "FIXME" "BUG")
  "Keywords to highlight with `font-lock-todo-face'.")

(defface font-lock-todo-face '((t :inherit font-lock-comment-face
                                  :background "yellow"))
  ;; TODO: XXX: FIXME: BUG: testing :)
  "Face for TODO keywords.")

(defun font-lock-todo-insinuate ()
  (let ((keyword-regexp
         (rx bow (group (eval (let ((lst '(or)))
                                (dolist (kw font-lock-todo-keywords)
                                  (push kw lst))
                                (nreverse lst))))
             ":")))
    (font-lock-add-keywords
     nil
     `((,keyword-regexp 1 'font-lock-todo-face prepend)))))

;; I don't use this much but I always forget the exact implementation, so this
;; is more to remember than anything else.
(defmacro setc (&rest vars-and-vals)
  "Set VARS-AND-VALS by customizing them or using set-default.
Use like `setq'."
  `(progn ,@(cl-loop for (var val) on vars-and-vals by #'cddr
                     if (null val) return (user-error "Not enough arguments")
                     collecting `(funcall (or (get ',var 'custom-get)
                                              #'set-default)
                                          ',var ',val)
                     into ret
                     finally return ret)))

(defun +set-faces (specs)
  "Set fonts to SPECS.
Specs is an alist: its cars are faces and its cdrs are the plist
passed to `set-face-attribute'.  Note that the FRAME argument is
always nil; this function is mostly intended for use in init."
  (dolist (spec specs)
    (apply #'set-face-attribute (car spec) nil (cdr spec))))

(defcustom chat-functions '(+irc
                            jabber-connect-all
                            ;; slack-start
                            )
  "Functions to start when calling `chat'."
  :type '(repeat function)
  :group 'applications)

(defun chat-disconnect ()
  "Disconnect from all chats."
  (interactive)
  (+with-progress "Quitting circe..."
    (ignore-errors
      (circe-command-GQUIT "peace love bread")
      (cancel-timer (irc-connection-get conn :flood-timer))))
  (+with-progress "Quitting jabber..."
    (ignore-errors
      (jabber-disconnect)))
  (when (boundp '+slack-teams)
    (+with-progress "Quitting-slack..."
             (dolist (team +slack-teams)
               (ignore-errors
                 (slack-team-disconnect team)))
             (ignore-errors (slack-ws-close))))
  (+with-progress "Killing buffers..."
    (ignore-errors
      (+mapc-some-buffers (lambda () "Remove the buffer from tracking and kill it unconditionally."
                            (let ((kill-buffer-query-functions nil))
                              (tracking-remove-buffer (current-buffer))
                              (kill-buffer)))
                          (lambda () "Return t if derived from the following modes."
                            (derived-mode-p 'lui-mode
                                            'jabber-chat-mode
                                            'jabber-roster-mode
                                            'jabber-browse-mode
                                            'slack-mode))))))

;; I can never remember all the damn chat things I run, so this just does all of em.
(defun chat (&optional arg)
  "Initiate all chat functions.
With optional ARG, kill all chat-related buffers first."
  (interactive "P")
  (when arg (chat-disconnect))
  (dolist-with-progress-reporter (fn chat-functions)
      "Connecting to chat..."
    (call-interactively fn)))

(defun +forward-paragraph (arg)
  "Move forward ARG (simple) paragraphs.
A paragraph here is simply defined: it's a block of buffer that's
separated from others by two newlines."
  (interactive "p")
  (let ((direction (/ arg (abs arg))))
    (forward-line direction)
    (while (not (or (bobp)
                    (eobp)
                    (= arg 0)))
      (if (looking-at "^[ \f\t]*$")
          (setq arg (- arg direction))
        (forward-line direction)))))

(defun +backward-paragraph (arg)
  "Move backward ARG (simple) paragraphs.
See `+forward-paragraph' for the behavior."
  (interactive "p")
  (+forward-paragraph (- arg)))

(defun +concat (&rest strings)
  "Concat STRINGS separated by SEPARATOR.
Each item in STRINGS is either a string or a list or strings,
which is concatenated without any separator.

SEPARATOR defaults to the newline (\\n)."
  (let (ret
        ;; I don't know why a `cl-defun' with
        ;; (&rest strings &key (separator "\n")) doesn't work
        (separator (or (cl-loop for i from 0 upto (length strings)
                                if (eq (nth i strings) :separator)
                                return (nth (1+ i) strings))
                       "\n")))
    (while strings
      (let ((string (pop strings)))
        (cond ((eq string :separator) (pop strings))
              ((listp string) (push (apply #'concat string) ret))
              ((stringp string) (push string ret)))))
    (mapconcat #'identity (nreverse ret) separator)))

(defun +file-string (file)
  "Fetch the contents of FILE and return its string."
  (with-current-buffer (find-file-noselect file)
    (buffer-string)))

(defmacro +with-progress (pr-args &rest body)
  "Perform BODY wrapped in a progress reporter.
PR-ARGS is the list of arguments to pass to
`make-progress-reporter'; it can be a single string for the
message, as well.  If you want to use a formatted string, wrap
the `format' call in a list."
  (declare (indent 1))
  (let ((reporter (gensym))
        (pr-args (if (listp pr-args) pr-args (list pr-args))))
    `(let ((,reporter (make-progress-reporter ,@pr-args)))
       (prog1 (progn ,@body)
         (progress-reporter-done ,reporter)))))

(defmacro +with-eval-after-loads (features &rest body)
  "Execute BODY after all FEATURES are loaded."
  (declare (indent 1) (debug (form def-body)))
  (unless (listp features)
    (setq features (list features)))
  (if (null features)
      (macroexp-progn body)
    (let* ((this (car features))
           (rest (cdr features)))
      `(with-eval-after-load ',this
         (+with-eval-after-loads ,rest ,@body)))))

(defun +scratch-buffer (&optional nomode)
  "Create a new scratch buffer and switch to it.
If the region is active, paste its contents into the scratch
buffer.  The scratch buffer inherits the mode of the current
buffer unless NOMODE is non-nil.  When called interactively,
NOMODE will be set when called with \\[universal-argument]."
  (interactive "P")
  (let* ((mode major-mode)
         (bufname (generate-new-buffer-name (format "*scratch (%s)*" mode)))
         (paste (and (region-active-p)
                     (prog1
                         (buffer-substring (mark t) (point))
                       (deactivate-mark)))))
    (when (and (not nomode)
               (bound-and-true-p ess-dialect)) ; Not sure what `ess-dialect' is
      (setq mode (intern-soft (concat ess-dialect "-mode"))))
    ;; Set up buffer
    (switch-to-buffer (get-buffer-create bufname))
    (when (and (not nomode) mode)
      (ignore-errors (funcall mode)))
    (insert (format "%s Scratch buffer for %s%s\n\n"
                    comment-start mode comment-end))
    (when paste (insert paste))
    (get-buffer bufname)))

(defun +indent-rigidly (arg &optional interactive)
  "Indent all lines in the region, or the current line.
This calls `indent-rigidly' and passes ARG to it."
  (interactive "P\np")
  (unless (region-active-p)
    (push-mark)
    (push-mark (line-beginning-position) nil t)
    (goto-char (line-end-position)))
  (call-interactively #'indent-rigidly))

(defun +sort-lines (reverse beg end)
  "Sort lines in region, ignoring leading whitespace.
REVERSE non-nil means descending order; interactively, REVERSE is
the prefix argument, and BEG and END are the region.  The
variable `sort-fold-case' determines whether case affects the
sort order."
  (interactive "P\nr")
  (save-excursion
    (save-restriction
      (narrow-to-region beg end)
      (goto-char (point-min))
      (let ((inhibit-field-text-motion t))
        (sort-subr reverse
                   #'forward-line
                   #'end-of-line
                   #'beginning-of-line-text)))))

(defun +crm-indicator (args)
  "AROUND advice for `completing-read-multiple'."
  ;; [[https://github.com/minad/vertico/blob/8ab2cddf3a1fb8799611b1d35118bf579aaf3154/README.org][from vertico's README]]
  (cons (format "[CRM%s] %s"
                (replace-regexp-in-string
                 "\\`\\[.*?]\\*\\|\\[.*?]\\*\\'" ""
                 crm-separator)
                (car args))
        (cdr args)))


;;; Timers!
;; inspired by [[https://git.sr.ht/~protesilaos/tmr/tree/main/item/tmr.el][prot's tmr.el package]]

(defvar +timer-string nil)
(defvar +timer-timer nil)

(defcustom +timer-running-string "⏰"
  "What to display when the timer is running."
  :type 'string)
(defcustom +timer-done-string "❗"
  "What to display when the timer is done."
  :type 'string)

(defun +timer (time)
  "Set a timer for TIME."
  (interactive (list (read-string "Set a timer for how long? ")))
  (let ((secs (cond ((natnump time) (* time 60))
                    ((and (stringp time)
                          (string-match-p "[0-9]\\'" time))
                     (* (string-to-number time) 60))
                    (t (let ((secs 0)
                             (time time))
                         (save-match-data
                           (while (string-match "\\([0-9.]+\\)\\([hms]\\)" time)
                             (cl-incf secs
                                      (* (string-to-number (match-string 1 time))
                                         (pcase (match-string 2 time)
                                           ("h" 3600)
                                           ("m" 60)
                                           ("s" 1))))
                             (setq time (substring time (match-end 0)))))
                         secs)))))
    (message "Setting timer for \"%s\" (%S seconds)..." time secs)
    (setq +timer-string +timer-running-string)
    (setq +timer-timer (run-with-timer secs nil
                                       (lambda ()
                                         (message "%S-second timer DONE!" secs)
                                         (setq +timer-string +timer-done-string)
                                         (let ((visible-bell t)
                                               (ring-bell-function nil))
                                           (ding))
                                         (ding))))))

(defun +timer-cancel ()
  "Cancel the running timer."
  (interactive)
  (cond ((not +timer-timer)
         (message "No timer found!"))
        (t
         (cancel-timer +timer-timer)
         (message "Timer canceled.")))
  (setq +timer-string nil))



(defun +switch-to-last-buffer ()
  "Switch to the last-used buffer in this window."
  (interactive)
  (switch-to-buffer nil))

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