path: root/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:

(require 'cl-lib)

;;; 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.

;; Why isn't this a thing???
(defmacro fbound-and-true-p (func)
  "Return the value of function FUNC if it is bound, else nil."
  `(and (fboundp ,func) ,func))

(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-eval-after-loads (files &rest body)
  "Execute BODY after FILES are loaded.
This macro simplifies `with-eval-after-load' for multiple nested
features."
  (declare (indent 1) (debug (form def-body)))
  (waterfall-list 'with-eval-after-load files body))

(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)))

(defun clone-buffer-write-file (filename &optional confirm)
  "Clone current buffer to a file named FILENAME and switch.
FILENAME and CONFIRM are passed directly to `write-file'."
  (interactive                          ; stolen from `write-file'
   (list (if buffer-file-name
             (read-file-name "Write file: "
                             nil nil nil nil)
           (read-file-name "Write file: " default-directory
                           (expand-file-name
                            (file-name-nondirectory (buffer-name))
                            default-directory)
                           nil nil))
         (not current-prefix-arg)))
  (let ((buf (clone-buffer nil nil)))
    (with-current-buffer buf
      (write-file filename confirm))
    (switch-to-buffer buf)))

(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)))

(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))
    (if (bound-and-true-p paredit-mode)
        (paredit-backward-kill-word)
      (backward-kill-word arg))))

(defun unfill-buffer (&optional buffer-or-name)
  (with-current-buffer (or buffer-or-name (current-buffer))
    (save-excursion
      (save-restriction
        (unfill-region (point-min) (point-max))))))

;; https://www.emacswiki.org/emacs/UnfillRegion
(defun unfill-region (start end)
  "Unfill a region defined by START and END positions."
  (interactive "*r")
  (let ((fill-column (point-max))
        (emacs-lisp-docstring-fill-column t))
    (fill-region start end)))

(defun waterfall-list (car list rest)
  "Cons CAR with each element in LIST in a waterfall fashion, end with REST.
For use with the `with-eval-after-loads' function."
  (cond ((atom list) `(,car ',list ,@rest))
        ((= 1 (length list)) `(,car ',(car list) ,@rest))
        (t
         `(,car ',(car list)
                ,(waterfall-list car (cdr list) rest)))))


;;; 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
;; and https://github.com/alphapapa/unpackaged.el/issues/20

(defun sort-sexps (beg end &optional key)
  "Sort sexps in region.
Comments stay with the code below.  KEY is a function to sort by,
e.g. (lambda (sexp) (symbol-name (car sexp)))"
  (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)
                                     (if key
                                         (funcall key sexp)
                                       (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/copy-region-plain (start end)
  "Copy a region to clipboard, removing all Org formatting."
  (interactive "r")
  (let ((s (buffer-substring-no-properties start end))
        (extracted-heading (when (derived-mode-p 'org-mode)
                             (acdw/org-extract-heading-text))))
    (with-temp-buffer
      (insert s)
      (let ((sentence-end-double-space nil))
        ;; Remove org stuff
        (when extracted-heading         ; Replace org heading with plaintext
          (goto-char (point-min))
          (kill-line)
          (insert extracted-heading))
        (replace-regexp org-property-drawer-re "") ;Delete properties
        (replace-regexp org-logbook-drawer-re "") ;Delete logbook
        (replace-regexp org-list-full-item-re "
\4")
        ;; Re-fill text for clipboard
        (unfill-region (point-min) (point-max))
        (flush-lines "^$" (point-min) (point-max)))
      ;; Copy buffer
      (copy-region-as-kill (point-min) (point-max))))
  (when (called-interactively-p 'interactive)
    (indicate-copied-region))
  (setq deactivate-mark t)
  nil)

(defun acdw/org-extract-heading-text ()
  (let ((heading (org-no-properties (org-get-heading t t t t))))
    (message
     (replace-regexp-in-string org-link-bracket-re
                               (lambda (match)
                                 (match-string-no-properties 2 match))
                               heading))))

(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"))))))

(defun acdw/require-private ()
  "Load \"~/.emacs.d/private.el\".
It's called 'require-private' for historical reasons."
  (load (expand-file-name "private.el" user-emacs-directory)
        :noerror :nomessage))


;;; 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"
  :keymap (let ((map (make-sparse-keymap)))
            (when-let ((link-cmd (or (fbound-and-true-p #'ace-link)
                                     (fbound-and-true-p #'link-hint-open-link))))
              (define-key map (kbd ";") link-cmd)
              (define-key map (kbd "o") link-cmd))
            map)
  (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 '(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))
      (when (fboundp mode)
        (funcall mode -1)))))


;;; Sort setq...
;; https://emacs.stackexchange.com/questions/33039/

(defun sort-setq ()
  (interactive)
  (save-excursion
    (save-restriction
      (let ((sort-end (progn (end-of-defun)
                             (backward-char)
                             (point-marker)))
            (sort-beg (progn (beginning-of-defun)
                             (re-search-forward "[ \\t]*(" (point-at-eol))
                             (forward-sexp)
                             (re-search-forward "\\<" (point-at-eol))
                             (point-marker))))
        (narrow-to-region (1- sort-beg) (1+ sort-end))
        (sort-subr nil #'sort-setq-next-record #'sort-setq-end-record)))))

(defun sort-setq-next-record ()
  (condition-case nil
      (progn
        (forward-sexp 1)
        (backward-sexp))
    ('scan-error (end-of-buffer))))

(defun sort-setq-end-record ()
  (condition-case nil
      (forward-sexp 2)
    ('scan-error (end-of-buffer))))


;;; Crux tweaks

;; `crux-other-window-or-switch-buffer' doesn't take an argument.
(defun acdw/other-window-or-switch-buffer (&optional arg)
  "Call `other-window' or switch buffers, depending on window count."
  (interactive "P")
  (if (one-window-p)
      (switch-to-buffer nil)
    (other-window (or arg 1))))

(defun acdw/other-window-or-switch-buffer-backward ()
  (interactive)
  (acdw/other-window-or-switch-buffer -1))


;;; Auth-sources
;; https://github.com/emacs-circe/circe/wiki/Configuration
(defun acdw/fetch-password (&rest params)
  "Fetch a password from `auth-source'."
  (require 'auth-source)
  (let ((match (car (apply #'auth-source-search params))))
    (if match
        (let ((secret (plist-get match :secret)))
          (if (functionp secret)
              (funcall secret)
            secret))
      (message "Password not found for %S" params))))

(defun acdw/make-password-fetcher (&rest params)
  "Make a function that will fetch a password using `acdw/fetch-password'."
  (lambda (&rest _)
    (apply #'acdw/fetch-password params)))


;;; Paren annoyances
(defun acdw/stop-paren-annoyances (&optional buffer)
  "Locally turn off paren-checking functions in BUFFER."
  (with-current-buffer (or buffer (current-buffer))
    (setq-local blink-matching-paren nil
                show-paren-mode nil)))

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