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:

;;; Variables

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

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


;;; 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."
  (pcase 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"))))))


;;; Keymaps

(defvar acdw/leader
  (let ((map (make-sparse-keymap))
        (c-z (global-key-binding "\C-z")))
    (global-set-key "\C-z" map)
    (define-key map "\C-z" c-z)
    map))


;;; 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 mode-line-format
                    '(:eval
                      (let* ((fmt " Reading %b")
                             (len (length (format-mode-line fmt))))
                        (concat
                         (propertize " "
                                     'display `((space :align-to (- right
                                                                    ,len)))
                                     'face '(:inherit italic))
                         fmt)))
                    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)
    (kill-local-variable 'mode-line-format)
    ;; 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