path: root/lisp/yoke.el

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