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."
  (let ((pred (or predicate t)))
    (dolist (buf (buffer-list))
      (with-current-buffer buf
        (when (if (or (eq (car-safe pred) 'closure)
                      (fboundp pred))
                  (funcall pred)
                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")))))

(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 (derived-mode-p 'special-mode 'lui-mode 'comint-mode)
    ;; 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 "☮ 🫀 🍞")
      (cancel-timer (irc-connection-get conn :flood-timer))))
  (+with-progress "Quitting jabber..."
    (ignore-errors
      (jabber-disconnect)))
  (+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)))))

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