emacs/lisp/acdw.el

;;; acdw.el -*- lexical-binding: t; coding: utf-8-unix -*-

;; Author: Case Duckworth <acdw@acdw.net>
;; Created: Sometime during Covid-19, 2020
;; Keywords: configuration
;; URL: https://tildegit.org/acdw/emacs

;; This file is NOT part of GNU Emacs.

;;; License:
;; Everyone is permitted to do whatever with this software, without
;; limitation.  This software comes without any warranty whatsoever,
;; but with two pieces of advice:
;; - Don't hurt yourself.
;; - Make good choices.

;;; Commentary:
;; `acdw.el' contains `acdw/map', its mode, and assorted ease-of-life
;; functions for me, acdw.

;;; Code:

;;; Variables

(defconst acdw/system
  (pcase system-type
    ('gnu/linux :home)
    ((or 'msdos 'windows-nt) :work)
    (_ :other))
  "Which computer system is currently being used.")

(defmacro acdw/system (&rest args)
  "Convenience macro for interfacing with `acdw/system'.

When called without arguments, it returns `acdw/system'.  When
called with one (symbol) argument, it returns (eq acdw/system
ARG).  When called with multiple arguments or a list, it returns
`pcase' over each argument."
  (cond
   ((null args) acdw/system)
   ((atom (car args))
    `(when (eq acdw/system ,(car args))
       ,(car args)))
   (t
    `(pcase acdw/system
       ,@args))))


;;; Utility functions
;; I don't prefix these because ... reasons.  Honestly I probably should prefix
;; them.

(defun dos2unix (buffer)
  "Replace \r\n with \n in BUFFER."
  (interactive "*b")
  (save-excursion
    (goto-char (point-min))
    (while (search-forward (string ?\C-m ?\C-j) nil t)
      (replace-match (string ?\C-j) nil t))))

(defun expand-file-name-exists-p (&rest expand-file-name-args)
  "Call `expand-file-name' on EXPAND-FILE-NAME-ARGS, returning
  its name if it exists, or NIL otherwise."
  (let ((file (apply #'expand-file-name expand-file-name-args)))
    (if (file-exists-p file)
        file
      nil)))

;; (defmacro hook-defun (name hooks &rest forms)
;;   "Define a function NAME that executes FORMS, and add it to
;; each hook in HOOKS."
;;   (declare (indent 2))
;;   (let ((func-name (intern (concat "hook-defun-" (symbol-name name))))
;;         (hook-list (if (consp hooks) hooks (list hooks)))
;;         (hook-defun-add-hook-list))
;;     `(progn
;;        (defun ,func-name () "Defined by `hook-defun'." ,@forms)
;;        ,@(dolist (hook hook-list hook-defun-add-hook-list)
;;            (push `(add-hook ',hook #',func-name) hook-defun-add-hook-list)))))

(defun kill-region-or-backward-word (arg)
  "Kill region if active, or backward word if not."
  (interactive "p")
  (if (region-active-p)
      (kill-region (region-beginning) (region-end))
    (backward-kill-word arg)))

(defmacro when-unfocused (name &rest forms)
  "Define a function NAME, executing FORMS, that fires when Emacs
is unfocused."
  (declare (indent 1))
  (let ((func-name (intern (concat "when-unfocused-" (symbol-name name)))))
    `(progn
       (defun ,func-name () "Defined by `when-unfocused'."
              (when (seq-every-p #'null
                                 (mapcar #'frame-focus-state (frame-list)))
                ,@forms))
       (add-function :after after-focus-change-function #',func-name))))

(defmacro with-message (message &rest body)
  "Execute BODY, messaging 'MESSAGE...' before and 'MESSAGE... Done.' after."
  (declare (indent 1))
  ;; Wrap a progn inside a prog1 to return the return value of the body.
  `(prog1
       (progn (message "%s..." ,message)
              ,@body)
     (message "%s... Done." ,message)))


;;; Comment-or-uncomment-sexp
;; from https://endlessparentheses.com/a-comment-or-uncomment-sexp-command.html

(defun uncomment-sexp (&optional n)
  "Uncomment a sexp around point."
  (interactive "P")
  (let* ((initial-point (point-marker))
         (inhibit-field-text-motion t)
         (p)
         (end (save-excursion
                (when (elt (syntax-ppss) 4)
                  (re-search-backward comment-start-skip
                                      (line-beginning-position)
                                      t))
                (setq p (point-marker))
                (comment-forward (point-max))
                (point-marker)))
         (beg (save-excursion
                (forward-line 0)
                (while (and (not (bobp))
                            (= end (save-excursion
                                     (comment-forward (point-max))
                                     (point))))
                  (forward-line -1))
                (goto-char (line-end-position))
                (re-search-backward comment-start-skip
                                    (line-beginning-position)
                                    t)
                (ignore-errors
                  (while (looking-at-p comment-start-skip)
                    (forward-char -1)))
                (point-marker))))
    (unless (= beg end)
      (uncomment-region beg end)
      (goto-char p)
      ;; Indentify the "top-level" sexp inside the comment.
      (while (and (ignore-errors (backward-up-list) t)
                  (>= (point) beg))
        (skip-chars-backward (rx (syntax expression-prefix)))
        (setq p (point-marker)))
      ;; Re-comment everything before it. 
      (ignore-errors
        (comment-region beg p))
      ;; And everything after it.
      (goto-char p)
      (forward-sexp (or n 1))
      (skip-chars-forward "\r\n[:blank:]")
      (if (< (point) end)
          (ignore-errors
            (comment-region (point) end))
        ;; If this is a closing delimiter, pull it up.
        (goto-char end)
        (skip-chars-forward "\r\n[:blank:]")
        (when (eq 5 (car (syntax-after (point))))
          (delete-indentation))))
    ;; Without a prefix, it's more useful to leave point where
    ;; it was.
    (unless n
      (goto-char initial-point))))

(defun comment-sexp--raw ()
  "Comment the sexp at point or ahead of point."
  (pcase (or (bounds-of-thing-at-point 'sexp)
             (save-excursion
               (skip-chars-forward "\r\n[:blank:]")
               (bounds-of-thing-at-point 'sexp)))
    (`(,l . ,r)
     (goto-char r)
     (skip-chars-forward "\r\n[:blank:]")
     (save-excursion
       (comment-region l r))
     (skip-chars-forward "\r\n[:blank:]"))))

(defun comment-or-uncomment-sexp (&optional n)
  "Comment the sexp at point and move past it.
If already inside (or before) a comment, uncomment instead.
With a prefix argument N, (un)comment that many sexps."
  (interactive "P")
  (if (or (elt (syntax-ppss) 4)
          (< (save-excursion
               (skip-chars-forward "\r\n[:blank:]")
               (point))
             (save-excursion
               (comment-forward 1)
               (point))))
      (uncomment-sexp n)
    (dotimes (_ (or n 1))
      (comment-sexp--raw))))


;;; Sort sexps
;; from https://github.com/alphapapa/unpackaged.el#sort-sexps

(defun sort-sexps (beg end)
  "Sort sexps in region.
Comments stay with the code below."
  (interactive "r")
  (cl-flet ((skip-whitespace () (while (looking-at (rx (1+ (or space "\n"))))
                                  (goto-char (match-end 0))))
            (skip-both () (while (cond ((or (nth 4 (syntax-ppss))
                                            (ignore-errors
                                              (save-excursion
                                                (forward-char 1)
                                                (nth 4 (syntax-ppss)))))
                                        (forward-line 1))
                                       ((looking-at (rx (1+ (or space "\n"))))
                                        (goto-char (match-end 0)))))))
    (save-excursion
      (save-restriction
        (narrow-to-region beg end)
        (goto-char beg)
        (skip-both)
        (cl-destructuring-bind (sexps markers)
            (cl-loop do (skip-whitespace)
                     for start = (point-marker)
                     for sexp = (ignore-errors
                                  (read (current-buffer)))
                     for end = (point-marker)
                     while sexp
                     ;; Collect the real string, then one used for sorting.
                     collect (cons (buffer-substring (marker-position start) (marker-position end))
                                   (save-excursion
                                     (goto-char (marker-position start))
                                     (skip-both)
                                     (buffer-substring (point) (marker-position end))))
                     into sexps
                     collect (cons start end)
                     into markers
                     finally return (list sexps markers))
          (setq sexps (sort sexps (lambda (a b)
                                    (string< (cdr a) (cdr b)))))
          (cl-loop for (real . sort) in sexps
                   for (start . end) in markers
                   do (progn
                        (goto-char (marker-position start))
                        (insert-before-markers real)
                        (delete-region (point) (marker-position end)))))))))


;;; Emacs configuration functions

(defun emacs-git-pull-config (&optional remote branch)
  "`git-pull' emacs configuration from REMOTE and BRANCH.

REMOTE defaults to 'origin', BRANCH to 'main'."
  (let ((remote (or remote "origin"))
        (branch (or branch "main")))
    (with-message (format "Pulling Emacs's configuration from %s" branch)
      (shell-command (concat "git -C "
                             "\"" (expand-file-name user-emacs-directory) "\""
                             " pull " remote " " branch)
                     (get-buffer-create "*emacs-git-pull-config-output*")
                     (get-buffer-create "*emacs-git-pull-config-error*")))))

(defun emacs-reload (&optional git-pull-first)
  "Reload Emacs's configuration files.

With a prefix argument, run git pull on the repo first."
  (interactive "P")
  (when git-pull-first
    (emacs-git-pull-config))
  (let ((init-files (append
                     ;; Load lisp libraries first, in case their functionality
                     ;; is used by {early-,}init.el
                     (let* ((dir (expand-file-name "lisp/"
                                                   user-emacs-directory))
                            (full-name (lambda (f)
                                         (concat
                                          (file-name-as-directory dir) f))))
                       (mapcar full-name (directory-files dir nil "\\.el\\'")))
                     ;; Load regular init files
                     (list (locate-user-emacs-file "early-init.el")
                           (locate-user-emacs-file "init.el" ".emacs"))))
        (debug-on-error t))
    (with-message "Saving init files"
      (save-some-buffers :no-confirm (lambda () (member (buffer-file-name)
                                                        init-files))))
    (dolist (file init-files)
      (with-message (format "Loading %s" file)
        (when (file-exists-p file)
          (load-file file))))))


;;; Specialized functions

(defun acdw/dir (&optional file make-directory)
  "Place Emacs files in one place.

If called without parameters, `acdw/dir' expands to
~/.emacs.d/var or similar.  If called with FILE, `acdw/dir'
expands FILE to ~/.emacs.d/var, optionally making its directory
if MAKE-DIRECTORY is non-nil."
  (let ((dir (expand-file-name (convert-standard-filename "var/")
                               user-emacs-directory)))
    (if file
        (let ((file-name (expand-file-name (convert-standard-filename file)
                                           dir)))
          (when make-directory
            (make-directory (file-name-directory file-name) 'parents))
          file-name)
      dir)))

(defun acdw/find-emacs-dotfiles ()
  "Finds lisp files in `user-emacs-directory' and passes them to
  `completing-read'."
  (interactive)
  (find-file (completing-read ".emacs: "
                              (directory-files-recursively
                               user-emacs-directory "\.el$"))))

(defun acdw/find-emacs-source ()
  "Find where Emacs keeps its source tree."
  (acdw/system
   (:work (expand-file-name
           (concat "~/src/emacs-" emacs-version "/src")))
   (:home (expand-file-name "~/src/pkg/emacs/src/emacs-git/src"))
   (:other nil)))

(defun acdw/gc-disable ()
  "Functionally disable the Garbage collector."
  (setq gc-cons-threshold most-positive-fixnum
        gc-cons-percentage 0.8))

(defun acdw/gc-enable ()
  "Enable the Garbage collector."
  (setq gc-cons-threshold (* 800 1024 1024)
        gc-cons-percentage 0.1))

(defun acdw/insert-iso-date (with-time)
  "Insert the ISO-8601-formatted date, with optional time."
  (interactive "P")
  (let ((format (if with-time "%FT%T%z" "%F")))
    (insert (format-time-string format (current-time)))))

(defun acdw/kill-a-buffer (&optional prefix)
  "Kill a buffer based on the following rules:

C-x k         => Kill CURRENT buffer and window
C-u C-x k     => Kill OTHER buffer and window
C-u C-u C-x k => Kill ALL OTHER buffers and windows

Prompt only if there are unsaved changes."
  (interactive "P")
  (pcase (or (car prefix) 0)
    (0  (kill-current-buffer)
        (unless (one-window-p) (delete-window)))
    (4  (other-window 1)
        (kill-current-buffer)
        (unless (one-window-p) (delete-window)))
    (16 (mapc 'kill-buffer (delq (current-buffer) (buffer-list)))
        (delete-other-windows))))

(defun acdw/sunrise-sunset (sunrise-command sunset-command)
  "Run commands at sunrise and sunset."
  (let* ((times-regex (rx (* nonl)
                          (: (any ?s ?S) "unrise") " "
                          (group (repeat 1 2 digit) ":"
                                 (repeat 1 2 digit)
                                 (: (any ?a ?A ?p ?P) (any ?m ?M)))
                          (* nonl)
                          (: (any ?s ?S) "unset") " "
                          (group (repeat 1 2 digit) ":"
                                 (repeat 1 2 digit)
                                 (: (any ?a ?A ?p ?P) (any ?m ?M)))
                          (* nonl)))
         (ss (sunrise-sunset))
         (_m (string-match times-regex ss))
         (sunrise-time (match-string 1 ss))
         (sunset-time (match-string 2 ss)))
    (run-at-time sunrise-time (* 60 60 24) sunrise-command)
    (run-at-time sunset-time (* 60 60 24) sunset-command)
    (run-at-time "12:00am" (* 60 60 24) sunset-command)))

(defun acdw/setup-fringes ()
  "Set up fringes how I likes 'em."
  (define-fringe-bitmap 'left-curly-arrow
    [#b01100000
     #b00110000
     #b00011000
     #b00001100]
    4 8 'center)
  (define-fringe-bitmap 'right-curly-arrow
    [#b00000011
     #b00000110
     #b00001100
     #b00011000]
    4 8 'center)
  (define-fringe-bitmap 'left-arrow
    [#b01100000
     #b01010000]
    2 8 '(top t))
  (define-fringe-bitmap 'right-arrow
    [#b00000011
     #b00000101]
    2 8 '(top t))
  (setq-local indicate-empty-lines nil
              indicate-buffer-boundaries '((top . right)
                                           (bottom . right)))
  (custom-set-faces '(fringe
                      ((t (:foreground "dim gray"))))))


;;; URL regexp
;; really, I just want to add gemini:// protocol, but I'm going to do some
;; reverse-engineering here.

(defvar acdw/button-protocols '("http"
                                "https"
                                "shttp"
                                "shttps"
                                "ftp"
                                "file"
                                "gopher"
                                "nntp"
                                "news"
                                "telnet"
                                "wais"
                                "mailto"
                                "info")
  "The list of protocols to splice into `browse-url-button-regexp'.")

(defun acdw/build-button-url-regexp ()
  "Build `browse-url-button-regexp' from `acdw/button-protocols'.
I used `xr' (not included in Emacs) to get the RX form of the
default, so I can easily splice the list into it.  THIS IS
BRITTLE AF!!!"
  (rx-to-string                         ; thanks wgreenhouse!
   `(seq word-boundary
         (group
          (group
           (or "www."
               (seq
                (group (or ,@acdw/button-protocols))
                ":")))
          (opt
           (group "//"
                  (one-or-more
                   (any "0-9a-z" "._-"))
                  ":"
                  (zero-or-more
                   (any "0-9"))))
          (or
           (seq
            (one-or-more
             (any "0-9a-z" "!#$%&*+,./:;=?@\\_~-" word))
            "("
            (one-or-more
             (any "0-9a-z" "!#$%&*+,./:;=?@\\_~-" word))
            (zero-or-more
             (any "0-9a-z" "#$%&*+/=@\\_~-" word))
            ")"
            (opt
             (one-or-more
              (any "0-9a-z" "!#$%&*+,./:;=?@\\_~-" word))
             (any "0-9a-z" "#$%&*+/=@\\_~-" word)))
           (seq
            (one-or-more
             (any "0-9a-z" "!#$%&*+,./:;=?@\\_~-" word))
            (any "0-9a-z" "#$%&*+/=@\\_~-" word)))))))

(defun acdw/add-button-url-regexp-protocol (proto)
  "Add PROTO to `browse-url-button-regexp'
First, add PROTO to `acdw/button-protocols'.
Then, build `browse-url-button-regexp' with the new protocol."
  (add-to-list 'acdw/button-protocols proto)
  (setq-default browse-url-button-regexp (acdw/build-button-url-regexp)))


;;; Recentf renaming with dired
;; from ... somewhere.  'rjs', apparently?
;; I'm throwing these here because they look better here than in init.el.
;; Comments are "rjs"'s.

;; Magic advice to rename entries in recentf when moving files in
;; dired.
(defun rjs/recentf-rename-notify (oldname newname &rest args)
  (if (file-directory-p newname)
      (rjs/recentf-rename-directory oldname newname)
    (rjs/recentf-rename-file oldname newname)))

(defun rjs/recentf-rename-file (oldname newname)
  (setq recentf-list
        (mapcar (lambda (name)
                  (if (string-equal name oldname)
                      newname
                    oldname))
                recentf-list)))

(defun rjs/recentf-rename-directory (oldname newname)
  ;; oldname, newname and all entries of recentf-list should already
  ;; be absolute and normalised so I think this can just test whether
  ;; oldname is a prefix of the element.
  (setq recentf-list
        (mapcar (lambda (name)
                  (if (string-prefix-p oldname name)
                      (concat newname (substring name (length oldname)))
                    name))
                recentf-list)))


;;; Minor modes

(define-minor-mode acdw/reading-mode
  "A mode for reading."
  :init-value nil
  :lighter " Read"
  (if acdw/reading-mode
      (progn ;; turn on
        ;; settings
        (setq-local orig-indicate-empty-lines indicate-empty-lines
                    indicate-empty-lines nil
                    orig-indicate-buffer-boundaries indicate-buffer-boundaries
                    indicate-buffer-boundaries nil)
        ;; disable modes
        (dolist (mode '(display-fill-column-indicator-mode))
          (when (fboundp mode)
            (funcall mode -1)))
        ;; enable modes
        (dolist (mode '(iscroll-mode olivetti-mode))
          (when (fboundp mode)
            (funcall mode +1))))
    ;; turn off
    ;; settings
    (setq-local indicate-empty-lines orig-indicate-empty-lines
                indicate-buffer-boundaries orig-indicate-buffer-boundaries)
    ;; enable modes
    (dolist (mode '(display-fill-column-indicator-mode))
      (when (fboundp mode)
        (funcall mode +1)))
    ;; disable modes
    (dolist (mode '(olivetti-mode iscroll-mode))
      (when (fboundp mode)
        (funcall mode -1)))))

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