aboutsummaryrefslogblamecommitdiff
path: root/emacs/.emacs.d/lisp/my/my-package.el
blob: b591d0ffeb08fb08f346ec643400a527643add13 (plain) (tree)
1
2
3
4
5



                                                                                         























































































































































                                                                             
                                                         


































































































                                                                                                         



                                       



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