1 files changed, 0 insertions, 392 deletions

@@ -1,392 +0,0 @@
-;;; yoke.el --- Yoke configuration into your config -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2022  Case Duckworth
-
-;; Author: Case Duckworth <case@bob>
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; 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