;;; my-package.el -- Package related extensions for emacs core -*- lexical-binding: t -*-
;; Copyright (C) 2023 Free Software Foundation.
;; Author: Yuchen Pei <id@ypei.org>
;; Package-Requires: ((emacs "28.2"))
;; This file is part of dotfiles.
;; dotfiles is free software: you can redistribute it and/or modify it under
;; the terms of the GNU Affero General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; dotfiles is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
;; Public License for more details.
;; You should have received a copy of the GNU Affero General Public
;; License along with dotfiles. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Package related extensions for emacs core.
;;; Code:
;;; Needed by `my-keybind' for barebone profiles like "emms".
(require 'cl-lib)
;;; Much of the following is adapted from prot-dotfiles
(defcustom my-omit-packages nil
"List of package names to not load.
This instructs the relevant macros to not `require' the given
package."
:group 'my
:type '(repeat symbol))
(defcustom my-allowed-packages nil
"List of package names to load.
This instructs the relevant macros to not `require' packages not
in this list. Nil means all packages can be required."
:group 'my
:type '(repeat symbol))
(defun my-package-install (package &optional method)
"Install PACKAGE with optional METHOD.
If METHOD is nil or the `builtin' symbol, PACKAGE is not
installed as it is considered part of Emacs.
If METHOD is any non-nil value, install PACKAGE using
`package-install'."
(unless (or (eq method 'builtin) (null method))
(unless (package-installed-p package)
(unless package-archive-contents
(package-refresh-contents))
(package-install package))))
(defmacro my-package (package &rest body)
"Require PACKAGE with BODY configurations.
PACKAGE is an unquoted symbol that is passed to `require'. It
thus conforms with `featurep'.
BODY consists of ordinary Lisp expressions. There are,
nevertheless, two unquoted plists that are treated specially:
1. (:install METHOD)
2. (:delay NUMBER)
These plists can be anywhere in BODY and are not part of its
final expansion.
The :install property is the argument passed to
`my-package-install' and has the meaning of METHOD
described therein.
The :delay property makes the evaluation of PACKAGE with the
expanded BODY happen with `run-with-timer'.
Also see `my-configure'."
(declare (indent 1))
(when (or (not my-allowed-packages)
(memq package my-allowed-packages))
(unless (memq package my-omit-packages)
(let (install delay)
(dolist (element body)
(when (let ((len (proper-list-p element)))
(and len (zerop (% len 2))))
(pcase (car element)
(:install (setq install (cdr element)
body (delq element body)))
(:delay (setq delay (cadr element)
body (delq element body))))))
(let ((common `(,(when install
`(my-package-install ',package ,@install))
(require ',package)
,@body
)))
(cond
((featurep package)
`(progn ,@body))
(delay
`(run-with-timer ,delay nil (lambda () ,@(delq nil common))))
(t
`(progn ,@(delq nil common)))))))))
(defmacro my-keybind (keymap &rest definitions)
"Expand key binding DEFINITIONS for the given KEYMAP.
DEFINITIONS is a sequence of string and command pairs."
(declare (indent 1))
(unless (zerop (% (length definitions) 2))
(error "Uneven number of key+command pairs"))
(let ((keys (seq-filter #'stringp definitions))
;; We do accept nil as a definition: it unsets the given key.
(commands (seq-remove #'stringp definitions)))
`(when-let (((keymapp ,keymap))
(map ,keymap))
,@(mapcar
(lambda (pair)
(unless (and (null (car pair))
(null (cdr pair)))
`(define-key map (kbd ,(car pair)) ,(cdr pair))))
(cl-mapcar #'cons keys commands)))))
(defmacro my-configure (&rest body)
"Evaluate BODY as a `progn'.
BODY consists of ordinary Lisp expressions. The sole exception
is an unquoted plist of the form (:delay NUMBER) which evaluates
BODY with NUMBER seconds of `run-with-timer'.
Note that `my-configure' does not try to autoload
anything. Use it only for forms that evaluate regardless.
Also see `my-package'."
(declare (indent 0))
(let (delay)
(dolist (element body)
(when (let ((len (proper-list-p element)))
(and len (zerop (% len 2))))
(pcase (car element)
(:delay (setq delay (cadr element)
body (delq element body))))))
(if delay
`(run-with-timer ,delay nil (lambda () ,@body))
`(progn ,@body))))
(defvar my-local-config-file
(locate-user-emacs-file "local-config")
"Local emacs-lisp-data config file for machine-specific and personal
information. The content of the file should be an alist of (var-name
. var-value)")
(defun my-read-local-config ()
"Read local-config.
Read from `my-local-config-file' into `my-local-config'."
(interactive)
(setq my-local-config
(with-temp-buffer
(insert-file-contents my-local-config-file)
(read (current-buffer)))))
(defmacro my-setq-from-local (&rest var-names)
"Set variables with values from `local-config'.
Does not set variables that do not appear in `local-config'.
Note that symbols or list values in `local-config' need to be
quoted."
(cons 'setq
(mapcan
(lambda (var-name)
(when-let ((pair (assoc `,var-name my-local-config)))
`(,(car pair) ',(cdr pair))))
var-names)))
(defmacro my-setq-from-local-1 (&rest var-names)
"Update the local config before calling `my-setq-from-local'"
`(progn (my-read-local-config)
(my-setq-from-local ,@var-names)))
(defmacro my-get-from-local (var-name)
"Get the value of a variable from `local-config'"
`(alist-get ',var-name my-local-config))
(defmacro my-get-from-local-1 (var-name)
"Update the local config before calling `my-get-from-local'"
`(progn (my-read-local-config)
(my-get-from-local ,var-name)))
(defmacro my-override (func-name)
"Override a function named foo with a function named my-foo"
`(advice-add ',func-name :override #',(intern (format "my-%s" func-name))))
(defmacro my-server-idle-timer (var-name secs repeat function)
"Create an idle timer if we are in an emacsclient.
The timer has name VAR-NAME. If there is an existing time with the
same name, cancel that one first."
`(when (my-server-p)
(when (and (boundp ',var-name) (timerp ,var-name))
(cancel-timer ,var-name))
(setq ,var-name (run-with-idle-timer ,secs ,repeat ,function))))
(defmacro my-server-timer (var-name secs repeat function)
"Create a timer if we are in an emacsclient.
The timer has name VAR-NAME. If there is an existing time with the
same name, cancel that one first."
`(when (my-server-p)
(when (and (boundp ',var-name) (timerp ,var-name))
(cancel-timer ,var-name))
(setq ,var-name (run-with-timer ,secs ,repeat ,function))))
(defun my-describe-package-from-url (url)
(interactive "sUrl: ")
(when (string-match
"\\b\\(?:elpa.gnu.org/packages/\\|elpa.gnu.org/devel/\\|elpa.nongnu.org/nongnu/\\)\\(.*\\).html"
url)
(describe-package (intern (match-string 1 url)))))
(defun my-generate-local-config ()
"Generate a local config and insert it to a buffer named *local-config*"
(with-current-buffer (get-buffer-create "*local-config*")
(erase-buffer)
(insert
(pp
(seq-map
(lambda (var)
(cons var (when (boundp var) (symbol-value var))))
(seq-uniq
(my-collect-my-setqd-vars
(with-temp-buffer
(insert "(progn ")
(dolist (el (directory-files "~/.emacs.d/init" t
directory-files-no-dot-files-regexp))
(insert-file-contents el)
(goto-char (point-max)))
(insert ")")
(goto-char (point-min))
(read (current-buffer))
)))))))
(pop-to-buffer "*local-config*")
)
(defun my-collect-my-setqd-vars (xs)
"Collect vars that have been `my-setq-from-local''d"
(cond
((not (listp xs)) nil)
((not xs) nil)
((eq (car xs) 'my-setq-from-local)
(cdr xs))
(t (append (my-collect-my-setqd-vars (car xs))
(my-collect-my-setqd-vars (cdr xs))))))
(defsubst my-add-hooks (function hooks)
"Add function to hooks"
(dolist (hook hooks)
(add-hook hook function)))
(defvar my-common-packages
'(package windmove consult icomplete
my-utils my-buffer my-editing my-complete)
"Common packages to include with any profile")
(provide 'my-package)
;;; my-package.el ends here