;;; my-package.el -- Package related extensions for emacs core -*- lexical-binding: t -*- ;; Copyright (C) 2023 Free Software Foundation. ;; Author: Yuchen Pei ;; 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 . ;;; 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