From 33c7ddb09e0eae0796686c64ffa022a181145cc1 Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Wed, 4 Jan 2023 23:21:15 -0600 Subject: Restart ... again ... again --- lisp/yoke.el | 392 ----------------------------------------------------------- 1 file changed, 392 deletions(-) delete mode 100644 lisp/yoke.el (limited to 'lisp/yoke.el') diff --git a/lisp/yoke.el b/lisp/yoke.el deleted file mode 100644 index ec84f56..0000000 --- a/lisp/yoke.el +++ /dev/null @@ -1,392 +0,0 @@ -;;; yoke.el --- Yoke configuration into your config -*- lexical-binding: t; -*- - -;; Copyright (C) 2022 Case Duckworth - -;; Author: Case Duckworth -;; Keywords: convenience -;; Package-Version: 0.61803398875 -;; Homepage: https://junk.acdw.net/yoke.el -;; Package-Requires: ((emacs "28.1")) - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program 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 General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; THIS IS A WORK IN PROGRESS. DON'T USE IT. - -;;; Code: - -(require 'cl-lib) -(require 'package-vc) - -;;; User options - -(defgroup yoke nil - "Customizations for `yoke'." - :group 'convenience - :prefix "yoke-") - -(defcustom yoke-directory package-user-dir - "Where to put yoked packages." - :type 'file) - -(defcustom yoke-cache-directory (locate-user-emacs-file "yoke-cache" - "~/.yoke-cache") - "Where to put cached yoke files, like downloaded HTTP packages." - :type 'file) - -(defcustom yoke-debug-on-error nil - "Whether to throw up the debugger on a yoke error. -If nil, errors will be inserted in the `yoke-message-buffer'.") - -;;; Variables - -(defvar yoke-message-buffer " *yoke*" - "The buffer used for yoke messages.") - -(defvar yoke-selected-packages nil - "List of packages managed by `yoke'.") - -(defvar yoke-backends '(file http package) - "Backends handled by `yoke'.") - -;;; Main functionality - -(defmacro yoke (package &rest body) - "Yoke a package into your Emacs session. -PACKAGE is either a symbol, in which case `yoke' expands to -basically a named `progn' (good for grouping configuration), or a -list of the form (NAME . ARGS), where ARGS can be one of the -following: - -- nil: install NAME using `package'. -- a property list describing a package specification. Valid - key/value pairs include - - `:backend' (symbol) - A symbol of the yoke backend to use for installing the - package. See `yoke-backends' for allowed backends. - - `:url' (string) - The URL of the package's repository or source. - - `:lisp-dir' (string) - The repository-relative name of the directory to use for - loading lisp sources. If not given, it defaults to the - repo's root directory. - - Other pairs may be valid for a given backend; see that - backend's `yoke-install' function for more details. - -BODY is executed in a `condition-case' so that errors won't keep -the rest of Emacs from initializing. BODY can also be prepended -by the following keyword arguments: - - `:after' (FEATURE...) - - `:require' (FEATURE...) - - `:depends' (PACKAGE-SPEC...) - - `:build' (ACTION...) - - `:unless' (PREDICATE) - - `:when' (PREDICATE) - -Other keywords are ignored. - -\(fn (PACKAGE [SPEC]) [BODY-ARGS] BODY...)" - (declare (indent 1)) - (let* ((name (or (car-safe package) package)) - (backend (yoke--pget package :backend)) - ;; Body keyword arguments - (after (plist-get body :after)) - (depends (plist-get body :depends)) - (req (plist-get body :require)) - (buildp (plist-member body :build)) - (build (plist-get body :build)) - (whenp (plist-member body :when)) - (when (if whenp (plist-get body :when) t)) - (unlessp (plist-member body :unless)) - (unless (if unlessp (plist-get body :unless) nil)) - ;; Body - (body (let ((b body) r) - (while (consp b) - (if (keywordp (car b)) - (setf b (cdr b)) - (setf r (cons (car b) r))) - (setf b (cdr b))) - (reverse r))) - (esym (make-symbol "yoke-error"))) - ;; Body modifiers. These are applied in reverse order (that is, the last - ;; one will be on the outside). - ;; --- Require the current package - (when req - (setf body - (append (let (reqs) - (dolist (r (ensure-list req) reqs) - (let* ((feat (if (eq r t) name r)) - (+feat (intern (format "+%s" feat)))) - (push `(require ',feat) reqs) - (push `(require ',+feat nil :noerror) reqs))) - (reverse reqs)) - body))) - ;; --- Install the package - (when (consp package) - (push `(yoke-install ',(car package) ,@(cdr package)) - body)) - ;; --- Dependencies - (when depends - (setf body - (append (cl-loop for dep in (ensure-list depends) - collect `(or (yoke-install ',@(ensure-list dep)) - (error "Dependency (%s): %S" - ',dep ',package))) - body))) - ;; --- Load after - (when after - (setf body `((yoke--eval-after ,(cl-subst name t after) ,@body)))) - ;; --- Conditional expansion - (when (or whenp unlessp) - (setf body - (append (cond - ((and whenp unlessp) - `((when (or (not ,when) ,unless) - (signal 'yoke-predicate - '(:when ,when :unless ,unless))))) - (whenp - `((unless ,when (signal 'yoke-predicate - '(:when ,when))))) - (unlessp - `((when ,unless (signal 'yoke-predicate - '(:unless ,unless)))))) - body))) - ;; Expansion - `(condition-case ,esym - (cl-letf (((symbol-function 'package--save-selected-packages) - #'ignore)) - ;; Body - ,@body) - (:success - ,(unless (atom package) - `(setf (alist-get ',name yoke-selected-packages) - (list ,@(cdr-safe package)))) - ',package) - (t ,(if yoke-debug-on-error - `(signal (car ,esym) (cdr ,esym)) - `(message "(yoke) %s: %s" (car ,esym) (cdr ,esym))))))) - -;;; Installing packages - -(defun yoke-install (name &rest args) - "Install package NAME, with ARGS." - (let ((custom-file null-device) - (inhibit-message (and (not (plist-member args :update)) - (not debug-on-error))) - (messages-buffer-name yoke-message-buffer)) - (funcall - (intern - (format "yoke-install-%s" - (or (plist-get args :backend) - (yoke--guess-backend (plist-get args :url)) - 'package))) - name args)) - (yoke--clean-load-path) - ;; Don't return nil - t) - -(defun yoke-install-package (name args &optional tries) - "Install package NAME with ARGS using `package' machinery. -TRIES is an internal variable." - (let ((package-user-dir yoke-directory) - (url (plist-get args :url)) - (update (plist-get args :update)) - (dirname (expand-file-name (format "%s" name) - yoke-directory)) - (tries (or tries 0)) - load-dir autoloads-file-name) - (unless (file-exists-p dirname) - (setq dirname (or (car-safe (file-expand-wildcards - (concat dirname "*"))) - dirname))) - (setq load-dir - (expand-file-name (or (plist-get args :lisp-dir) "") dirname) - generated-autoload-file - (expand-file-name (format "%s-autoloads.el" name) load-dir)) - (prog1 - (condition-case error - (cond - ;; -- Commented on 2022-12-21 - ;; ((and (file-exists-p dirname) - ;; (not update)) - ;; (add-to-list 'load-path - ;; (expand-file-name - ;; (or (plist-get args :lisp-dir) "") - ;; dirname) - ;; nil #'equal) - ;; (require (intern (format "%s-autoloads" name)))) - ((and url update) - (package-vc-update (cadr (assoc name package-alist)))) - (update - (package-update name)) - (url - ;; I'm going to be honest here, this is extremely cursed. But I - ;; don't want to get asked about installing the packages, and when - ;; the user answers 'no', the function errors. So.. this. - (cl-letf (((symbol-function 'yes-or-no-p) #'ignore)) - (ignore-errors (package-vc-install (cons name args))))) - (:else - (package-install name))) - (file-error (if (> tries 1) - (error "(yoke) Can't install `%s'" name) - (package-refresh-contents) - (yoke-install-package name args (1+ tries))))) - (add-to-list 'load-path load-dir nil #'equal) - (loaddefs-generate load-dir generated-autoload-file) - ;; Do it again, if it doesn't actually /generate/ anything - (when (eq 'provide - (with-current-buffer (find-file-noselect generated-autoload-file) - (read (buffer-substring (point-min) (point-max))))) - (loaddefs-generate load-dir generated-autoload-file nil nil nil - :generate-full)) - (load generated-autoload-file :noerror) - (kill-buffer (get-file-buffer generated-autoload-file)) - (package-activate name)))) - -(defun yoke-install-http (name args) - "Install a package NAME using ARGS from an http source." - (let* ((url (plist-get args :url)) - (cached (expand-file-name (file-name-nondirectory url) - yoke-cache-directory)) - (update (plist-get args :update))) - (unless url - (error "No URL for HTTP download: %S" (cons name args))) - (when (or (not (file-exists-p cached)) - update) - (make-directory yoke-cache-directory :parents) - (message "Downloading `%s'..." url) - (let* ((url-debug t) - (buf (url-retrieve-synchronously url))) - (with-current-buffer buf - (goto-char (point-min)) - (delete-region (point) (1+ (re-search-forward "^$"))) - (write-file cached 1) - (message "Downloading `%s'...Done." url)))) - (package-install-file cached))) - -(defun yoke-install-file (name args) - "Install package NAME using ARGS from a file on-disk." - (let ((url (plist-get args :url)) - (update (plist-get args :update)) - (dirname (expand-file-name (format "%s" name) yoke-directory))) - (if (file-exists-p url) - ;; This takes care of updating too. - (package-install-file url) - (error "(yoke) No such file: `%s'" url)))) - -;;; Other package transactions - -(defun yoke--choose-package () - "Choose a package from `yoke-selected-packages'." - (assoc (intern (completing-read "Package: " yoke-selected-packages)) - yoke-selected-packages)) - -(defun yoke-update (name &rest args) - (interactive (yoke--choose-package)) - (save-window-excursion - (apply #'yoke-install name (append '(:update t) - args)))) - -(defun yoke-update-all () - (interactive) - (dolist (pkg yoke-selected-packages) - (apply #'yoke-update pkg))) - -;;; Emacs integration - -(defun yoke-imenu-insinuate () - "Insinuate `yoke' forms for `imenu'." - (require 'imenu) - (setf (alist-get "Yoke" imenu-generic-expression nil nil #'equal) - (list "(yoke[[:space:]]*(?\\([^\t\n )]*\\)" - 1)) - (with-eval-after-load 'consult-imenu - (setf (alist-get ?y (plist-get (alist-get 'emacs-lisp-mode - consult-imenu-config) - :types)) - '("Yoke")))) - -;;; Utility functions - -(defun yoke--pget (spec prop &optional default) - "Get PROP's value from SPEC, a yoke specification. -If KEY doesn't exist, return DEFAULT." - (let ((pl (or (and (plistp spec) spec) - (cdr-safe spec)))) - (if (plist-member pl prop) - (plist-get pl prop) - default))) - -(defun yoke--guess-backend (url) - "Guess the backend to use from URL. -If inconclusive, return nil." - (cond - ((or (string-prefix-p "file:" url t) - (string-prefix-p "~" url) - (string-prefix-p "/" url)) - 'file) - (:else nil))) - -(defun yoke--clean-load-path () - (when-let ((first (string-remove-suffix "/" (car load-path))) - (second (string-remove-suffix "/" (cadr load-path))) - (_ (equal first second))) - (setf load-path (cdr load-path)) - (setf (car load-path) second))) - -(defun yoke--eval-after-init (fn) - "Evaluate FN after inititation, or now if Emacs is initialized. -FN is called with no arguments." - (if after-init-time - (funcall fn) - (add-hook 'after-init-hook fn))) - -(defmacro yoke--eval-after (prereqs &rest body) - "Evaluate body after PREREQS. -PREREQS can be a feature, a number, `:init', or a list of those. - -Features are used as arguments to `eval-after-load'. Numbers are -used as arguments to `run-with-idle-timer'. `:init' will ensure BODY -runs after Emacs's init time. - -When given a list of PREREQS, `eval-after' will nest each one -from left to right." - (declare (indent 1) (debug (form def-body))) - (setf prereqs (ensure-list prereqs)) - (if (null prereqs) - (macroexp-progn body) - (let* ((this (car prereqs)) - (form `((lambda () (yoke--eval-after ,(cdr prereqs) ,@body))))) - (cond - ((eq this :init) - (append '(yoke--eval-after-init) form)) - ((numberp this) - (append `(run-with-idle-timer ,this nil) form)) - ((symbolp this) - (append `(eval-after-load ',this) form)) - (:else (user-error "Eval-after: Bad prereq: %S" this)))))) - -(provide 'yoke) -;;; yoke.el ends here -- cgit 1.4.1-21-gabe81