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 'simple-modeline)
(require 'minions)

;;; Utilities

(defun acdw/when-unfocused (func &rest args)
  "Call FUNC, with ARGS, iff all Emacs frames are out of focus.

Ready for use with `after-focus-change-function'."
  (when (seq-every-p #'null (mapcar #'frame-focus-state (frame-list)))
    (apply func args)))

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

;;; Mode line segments (for `simple-modeline')
(defun acdw/modeline-modified ()
  "Displays a color-coded buffer modification/read-only indicator in the mode-line."
  (if (not (string-match-p "\\*.*\\*" (buffer-name)))
      (let* ((read-only (and buffer-read-only (buffer-file-name)))
	     (modified (buffer-modified-p)))
	(propertize
	 (if read-only " ×" (if modified " ●" " ○"))
	 'face `(:inherit
		 ,(if modified 'simple-modeline-status-modified
		    (if read-only 'simple-modeline-status-error
		      'simple-modeline-unimportant)))
	 'help-echo (format
		     "Buffer is %s and %smodified\nmouse-1: Toggle read-only status."
		     (if read-only "read-only" "writable")
		     (if modified "" "not "))
	 'local-map (purecopy (simple-modeline-make-mouse-map
			       'mouse-1
			       (lambda (event)
				 (interactive "e")
				 (with-selected-window (posn-window (event-start event))
				   (read-only-mode 'toggle)))))
	 'mouse-face 'mode-line-highlight))))

(defun acdw/modeline-minions ()
  "Display a button for `minions-minor-modes-menu'."
  (concat
   " "
   (propertize
    "ⱷ"
    'help-echo (format
		"Minor modes menu\nmouse-1: show menu.")
    'local-map (purecopy (simple-modeline-make-mouse-map
			  'mouse-1
			  (lambda (event)
			    (interactive "e")
			    (with-selected-window (posn-window (event-start
								event))
			      (minions-minor-modes-menu)))))
    'mouse-face 'mode-line-highlight)))

;;; Directories (think `no-littering')

(defvar acdw/dir (expand-file-name
		  (convert-standard-filename "var/")
		  user-emacs-directory)
  "A directory to hold extra configuration and emacs data.")

(defun acdw/in-dir (file &optional make-directory)
  "Expand FILE relative to `acdw/dir', optionally creating its
directory."
  (let ((f (expand-file-name (convert-standard-filename file)
			     acdw/dir)))
    (when make-directory
      (make-directory (file-name-directory f) 'parents))
    f))

;;; Settings

(defun acdw/set (assignments)
  "Perform `customize-set-variable' on each of ASSIGNMENTS.

ASSIGNMENTS is a list where each element is of the form
(VARIABLE VALUE [COMMENT])."
  (let (setting)			; for return value
  (dolist (assignment assignments setting)
    (customize-set-variable (car assignment)
			    (cadr assignment)
			    (if (and (caddr assignment)
				     (stringp (caddr assignment)))
				(caddr assignment)
			      "Customized by `acdw/set'."))
    (setq setting (car assignment)))))

;;; Faces

(defun acdw/set-face (face spec)
  "Customize FACE according to SPEC, and register it with `customize'.
SPEC is as for `defface'."
  (put face 'customized-face spec)
  (face-spec-set face spec))

(defmacro acdw/set-faces (face-specs)
  "Run `acdw/set-face' over each face in FACE-SPECS."
  (let (face-list)
    (dolist (face face-specs)
      (push `(acdw/set-face ',(car face) ',(cdr face)) face-list))
    `(progn
       ,@face-list)))

;;; Hooks

(defmacro acdw/hooks (hooks funcs &optional depth local)
  "Add FUNCS to HOOKS.

Either HOOKS or FUNCS can be a list, in which case they're mapped
over to add all FUNCS to all HOOKS.  They can also be singletons,
in which case `acdw/hooks' acts pretty much like `add-hook'.

DEPTH and LOCAL apply to all HOOKS defined here.  If you need
more fine-grained control, just use `add-hook'."
  (let ((hooks (if (listp hooks) hooks (list hooks)))
	(funcs (if (listp funcs) funcs (list funcs)))
	(depth (if depth depth 0))
	(hook-list))
    (dolist (hook hooks)
      (dolist (func funcs)
	(push `(add-hook ',hook #',func ,depth ,local) hook-list)))
    `(progn
       ,@hook-list)))

(defmacro acdw/hooks-after (file hooks funcs &optional depth local)
  "Add FUNCS, from FILE, to HOOKS."
  (let ((funcs (if (listp funcs) funcs (list funcs)))
	(autoload-list))
    (dolist (func funcs)
      (add-to-list 'autoload-list `(autoload #',func ,file)))
    `(progn
       ,@autoload-list
       (acdw/hooks ,hooks ,funcs ,depth ,local))))

;;; Keybindings

(defvar acdw/bind-default-map 'acdw/map
  "The default keymap to use with `acdw/bind'.")

(defmacro acdw/bind (key command &rest args)
  "A simple key-binding macro to take care of the repetitive stuff
automatically.

If KEY is a vector, it's passed directly to `define-key',
otherwise it's wrapped in `kbd'.

The following keywords are recognized:

:after ARGS .. call `autoload' on COMMAND using ARGS before
	       binding the key.  ARGS can be just the filename to
	       load; in that case it's wrapped in a list.  
:map KEYMAP .. define KEY in KEYMAP instead of the
	       default `acdw/bind-default-map'."
  (let ((after (when-let (sym (plist-get args :after))
		    (if (not (listp sym))
			(list sym)
		      sym)))
	(keymap (or (plist-get args :map) acdw/bind-default-map))
	(keycode (if (vectorp key) key (kbd key)))
	(command-list))
    (push `(define-key ,keymap ,keycode ',command) command-list)
    (when after
      (push `(autoload ',command ,@after) command-list))
    `(progn
       ,@command-list)))

(defmacro acdw/binds (bindings)
  "Bind multiple keys at once."
  (let (bind-list)
    (dolist (bind bindings)
      (push `(acdw/bind ,@bind) bind-list))
    `(progn
       ,@bind-list)))

;; convenience
(defmacro acdw/bind-after-map (file keymap bindings)
  "Wrap multiple calls of `acdw/bind' after FILE and with KEYMAP.
KEYMAP can be nil."
  (declare (indent 2))
  (let ((bind-list)
	(extra-args (if keymap
			`(:after ,file :map ,keymap)
		      `(:after ,file))))
    (dolist (binding bindings)
	(push `(acdw/bind ,@binding ,@extra-args) bind-list))
    `(progn
       ,@bind-list)))

;;; Packages

(defmacro acdw/pkg (package &rest args)
  "Set up a package using `straight.el'.

ARGS can include the following keywords:

:now FORMS   .. run forms immediately.  
		Good for settings and auxiliary functions.
:then FORMS  .. run forms after loading PACKAGE, using `with-eval-after-load'.
:binds BINDS .. run `acdw/bind-after-map' on BINDS.
:hooks HOOKS .. run `acdw/hooks-after' on HOOKS."
  (declare (indent 1))
  (let ((now-forms (plist-get args :now))
	(binds (plist-get args :binds))
	(hooks (plist-get args :hooks))
	(then-forms (plist-get args :then))
	(requirement (if (listp package)
			 (car package)
		       package))
	(final-form))
    (when then-forms
      (push `(with-eval-after-load ',requirement ,@then-forms) final-form))
    (when hooks
      (push `(acdw/hooks-after ,(symbol-name requirement) ,@hooks) final-form))
    (when binds
      (push `(acdw/bind-after-map ,(symbol-name requirement) nil ,binds)
	    final-form))
    (when now-forms
      (push `(progn ,@now-forms) final-form))
    (push `(straight-use-package ',package) final-form)
    `(progn
       ,@final-form)))

;;; Keymap & Mode

(defvar acdw/map (make-sparse-keymap)
  "A keymap for my custom bindings.")

(define-minor-mode acdw/mode
  "A mode for `acdw/map'."
  :init-value t
  :lighter " acdw"
  :keymap acdw/map)
(define-globalized-minor-mode acdw/global-mode acdw/mode acdw/mode)

;; Disable `acdw/mode' in the minibuffer
(defun acdw/mode--disable ()
  "Disable `acdw/mode'."
  (acdw/mode -1))
(add-hook 'minibuffer-setup-hook #'acdw/mode--disable)

;; Set up a leader key for `acdw/mode'
(defvar acdw/leader
  (let ((map (make-sparse-keymap))
	(c-z (global-key-binding "\C-z")))
    (define-key acdw/map "\C-z" map)
    (define-key map "\C-z" c-z)
    map))

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

;;; Elephant graveyard

;; XXX NOT WORKING -- And is this even necessary?
;; (defmacro acdw/defun-hook (hook docstring &optional depth local &rest forms)
;;   "Add FORMS to a function described by DOCSTRING, then add that
;;  function to HOOK.  DOCSTRING is converted to a function name by
;;  calling `docstring-to-symbol', if it's a string, or used as-is
;;  otherwise.  The optional DEPTH and LOCAL are passed to
;;  `add-hook', if they're present (i.e., not a list).

;; This macro aims to split the difference between the syntax of
;; lambdas in hooks and the ability to easily disable hooks."
;;   (declare (indent 2))
;;   (let ((name (if (stringp docstring)
;;		  (docstring-to-symbol docstring "hook-")
;;		docstring)))
;;     (when (listp local) (push local forms) (setq local nil))
;;     (when (listp depth) (push depth forms) (setq depth 0))
;;     `(progn
;;        (defun ,name () ,@forms)
;;        (add-hook ,hook #',name ,depth ,local))))

;; Utilities XXX related to `acdw/defun-hook'
;; (defun docstring-to-symbol (docstring &optional prefix)
;;   "Convert a DOCSTRING to a symbol by lowercasing the string,
;; converting non-symbol-safe characters to '-', and calling
;;   `intern'.  Returns the created symbol."
;;   (let ((str (split-string (downcase docstring) "[ \f\t\n\r\v'\"`,]+"
;;			   :omit-nulls)))
;;     (when prefix (push prefix str))
;;     (intern (mapconcat #'identity str "-"))))