From a729a61c0a1cad6e99dd6f56dfd35e8ff141521e Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Fri, 28 Oct 2022 19:43:12 -0500 Subject: total rewrite of `yoke' --- lisp/yoke.el | 395 ++++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 245 insertions(+), 150 deletions(-) (limited to 'lisp') diff --git a/lisp/yoke.el b/lisp/yoke.el index e7a6fe9..46d30d5 100644 --- a/lisp/yoke.el +++ b/lisp/yoke.el @@ -1,184 +1,279 @@ -;;; yoke.el --- yoke packages in to your editing system -*- lexical-binding: t; -*- -;; by C. Duckworth -(provide 'yoke) +;;; yoke.el --- make your editor work for YOU -*- lexical-binding: t; -*- +;; Copyright (C) 2022 C. Duckworth + +;;; Commentary: + +;; What's the most basic functionality of a package manager? In my view, all a +;; package manager should do is fetch packages from wherever they are, and +;; provide the system with a method of accessing those packages' functionality. +;; In Emacs, this means downloading packages from the Internet and adding their +;; directories to `load-path'. That's what `yoke' tries to do. +;; +;; In fact, that's /all/ `yoke' tries to do, on the package front. It doesn't +;; automatically fetch dependencies. It doesnt' do much else of anything +;; --- hell, it doesn't have to generate autoloads or build the dang source +;; files if you don't want it to. /I/ have it do those things because I like a +;; few creature comforts, but you can turn 'em off. +;; +;; Instead of focusing too much on installing packages, `yoke' works harder to +;; group---to "yoke together," if you will---related configurations together, à +;; la `use-package' or `setup'. I used both of those packages before and found +;; each somewhat lacking, and what I really wanted was a fancy `progn' that I +;; could put whatever I want inside. So that's basically what `yoke' is. It's +;; a configuration macro that automatically fetches packages from their repos +;; and tells Emacs where they are, then executes its body in a `cl-block' for +;; ... reasons. That's it. + +;;; Code: + (require 'cl-lib) +;;; Customization options + (defgroup yoke nil - "Customizations for yoke, a package manager thing." + "Customizations for `yoke'." :group 'applications :prefix "yoke-") (defcustom yoke-dir (locate-user-emacs-file "yoke") - "Where yoke packages live." + "Where to put yoked packages." :type 'file) -(defun yoke-repo-local-p (repo) - (string-match-p (rx bos (or "." "~" "/")) repo)) - -(defun yoke-repo-dir (pkg repo) - (if (yoke-repo-local-p repo) - (expand-file-name repo) - (expand-file-name (format "%s" pkg) yoke-dir))) - -(defun yoke-git (repo &optional dir) - "Git REPO from the internet and put it into `yoke-dir'. -If DIR is passed, clone there; otherwise just clone. Return the -directory created." - (let ((dir (or dir (yoke-repo-dir (file-name-nondirectory repo) repo)))) - (unless (or (yoke-repo-local-p repo) (file-exists-p dir)) - (message "Downloading %S..." repo) - (call-process "git" nil (get-buffer-create "*yoke*") nil - "clone" repo dir) - (message "Downloading %S... done" repo)) - dir)) - -(defun yoke-lasso (pkg repo &optional load-path) - "Add PKG to `load-path' so it can be used. -If PKG is not installed, install it from REPO. Packages will be -installed to `yoke-dir'." - (let* ((dir (yoke-repo-dir pkg repo))) - (yoke-git repo dir) - (cond - ((file-exists-p dir) - (when (or load-path dir) - (add-to-list 'load-path (expand-file-name (or load-path dir)))) - ;; This bit is stolen from `straight'. - (eval-and-compile (require 'autoload)) - (let ((generated-autoload-file - (expand-file-name (format "%s-autoloads.el" pkg) dir)) - (backup-inhibited t) - (version-control 'never) - (message-log-max nil) - (inhibit-message t)) - (unless (file-exists-p generated-autoload-file) - (let ((find-file-hook nil) - (write-file-functions nil) - (debug-on-error nil) - (left-margin 0)) - (if (fboundp 'make-directory-autoloads) - (make-directory-autoloads dir generated-autoload-file) - (and (fboundp 'update-directory-autoloads) - (update-directory-autoloads dir))))) - (when-let ((buf (find-buffer-visiting generated-autoload-file))) - (kill-buffer buf)) - (load generated-autoload-file :noerror :nomessage))) - (t (user-error "Directory \"%s\" doesn't exist." dir))) - dir)) - -(defun yoke-get (key args) - "Get KEY's value from ARGS, or return nil. -Similar-ish to `plist-get', but works on non-proper plists." - (cond - ((null args) nil) - ((eq key (car args)) (cadr args)) - (t (yoke-get key (cdr args))))) - -(defmacro when1 (test &rest body) - "Like `when', but return the value of the test." +(defcustom yoke-get-default-fn #'yoke-get-git + "Default function to get packages with." + :type 'function) + +(defvar yoke-buffer "*yoke*" + "Buffer to use for yoke process output.") + +;;; GET YOKED + +(defmacro yoke (package + &rest body) + "Yoke PACKAGE to work with your Emacs. +Execute BODY afterward. + +\(fn (PACKAGE [REPO REPO-KEYWORDS]) [BODY-KEYWORDS] BODY...)" (declare (indent 1)) - (let ((g (gensym))) - `(let ((,g ,test)) - (when ,g - ,@body - ,g)))) - -(defun delete2 (list &rest elems) - "Delete each element of ELEMS, and the next item, from LIST." - (let ((r nil)) - (while (consp list) - (if (member (car list) elems) - (setf list (cdr list)) - (setf r (cons (car list) r))) - (setf list (cdr list))) - (reverse r))) - -(defun eval-after-init (fn) + (let* (;; State + (pkg (cond ((consp package) (car package)) + (:else package))) + (url (cond ((consp package) (cdr package)) + (:else nil))) + (pname (intern (format "yoke:%s" pkg))) + (dirvar (gensym "yoke-dir-")) + ;; Keyword args + (after (plist-get body :after)) + (depends (plist-get body :depends)) + (whenp (plist-member body :when)) + (unlessp (plist-member body :unless)) + (when (cond (whenp (plist-get body :when)) + (:else t))) + (unless (cond (unlessp (plist-get body :unless)) + (:else nil))) + (autoload (cond ((plist-member body :autoload) + (plist-get body :autoload)) + (:else t))) + ;; Body + (body (cl-loop for (this next) on body by #'cddr + unless (keywordp this) + append (list this next) into ret + finally return (cond ((eq (car (last ret)) nil) + (butlast ret)) + (:else ret))))) + `(cl-block ,pname + (condition-case err + (progn + ;; Pass `:when' or `:unless' clauses + ,@(cond + ((and whenp unlessp) + `((when (or (not ,when) ,unless) + (cl-return-from ,pname + (format "%s (abort) :when %S :unless %S" + ',pname ',when ',unless))))) + (whenp + `((unless ,when (cl-return-from ,pname + (format "%s (abort) :when %S" + ',pname ',when))))) + (unlessp + `((when ,unless (cl-return-from ,pname + (format "%s (abort) :unless %S" + ',pname ',unless)))))) + ;; Get prerequisite packages + ,@(cl-loop + for (pkg* . yoke-get-args) in depends + collect `(or (let ((dir (yoke-get ,@yoke-get-args + :dir ,(format "%s" pkg*)))) + (and dir + ,@(if autoload + `((yoke-generate-autoloads ',pkg* dir)) + '(t)))) + (cl-return-from ,pname + (format "Error fetching prerequiste: %s" + ',pkg*)))) + ;; Download the package, generate autoloads + ,@(when url + `((let ((,dirvar (yoke-get ,@url :dir ,(format "%s" pkg)))) + ,@(when autoload + `((yoke-generate-autoloads ',pkg ,dirvar)))))) + ;; Evaluate the body, optionally after the features in `:after' + ,@(cond (after + `((eval-after ,after ,@body))) + (:else body))) + (:success ',package) + (t (message "%s: %s (%s)" ',pname (car err) (cdr err)) + nil))))) + +(defun yoke-get (url &rest args) + "\"Get\" URL and and put it in DIR, then add DIR to `load-path'. +URL can be a string or a list of the form (TYPE URL). The +download will be dispatched to the TYPE, or to +`yoke-get-default-fn' if only a string is given. +ARGS is a plist with the following possible keys: + +:dir DIRECTORY --- the directory to put the URL. +:load DIRECTORY --- the directory (relative to the download path) + to add to `load-path'. +:type TYPE --- one of `http', `git', or `file' --- how to + download URL." + (let* ((dir (plist-get args :dir)) + (load (plist-get args :load)) + (type (plist-get args :type)) + (path (cond + ((eq type 'http) (yoke-get-http url dir)) + ((or (eq type 'git) + (string-match-p (rx bos "git:") url)) + (yoke-get-git url dir)) + ((or (eq type 'file) + (string-match-p (rx bos (or "file:" "~" "/")) url)) + (yoke-get-file url dir)) + ((stringp url) + (funcall yoke-get-default-fn url dir)) + (:else (error "Uknown URL type: %S" url))))) + (cond + ((file-exists-p path) + (add-to-list 'load-path (expand-file-name (or load "") path)) + path) + (:else (error "Directory \"%s\" doesn't exist." path) + nil)))) + +(defun yoke-get--guess-directory (path &optional dir) + "Guess directory from PATH and DIR, and return it. +If DIR is present and relative, resolve it relative to +`yoke-dir', or if it's absolute, leave it as-is. If DIR is +absent, return the final component of PATH resolved relative to +`yoke-dir'." + (expand-file-name (or dir (file-name-nondirectory path)) + yoke-dir)) + +(defun yoke-get-http (url &optional dir) + "Download URL to DIR and return its directory. +If DIR isn't given, it's guessed from the final component of the +URL's path and placed under `yoke-dir'." + (let* ((dir (yoke-get--guess-directory url dir)) + (basename (file-name-nondirectory url)) + (filename (expand-file-name basename dir))) + (cond ((file-exists-p filename) + dir) + (:else + (message "Downloading %s..." url) + (with-current-buffer (let ((url-debug t)) + (url-retrieve-synchronously url)) + (condition-case e + (progn + (make-directory dir :parents) + (write-file filename 1) + (message "Downloading %s... Done" url)) + (:success dir) + (t (signal (car e) (cdr e))))))))) + +(defun yoke-get-git (repo &optional dir) + "Clone REPO to DIR and return its directory. +If DIR isn't given, it's guessed from the repo's name and put +under `yoke-dir'. Return the cloned directory's name on success, +or nil on failure." + (let ((dir (yoke-get--guess-directory repo dir))) + (cond ((file-exists-p dir) + dir) + (:else + (message "Cloning %s..." repo) + (pcase (call-process "git" nil (get-buffer-create yoke-buffer) nil + "clone" repo dir) + (0 (message "Cloning %s... Done" repo) + dir) + (_ (message "Cloning %s... Error! See buffer %s for output." + repo yoke-buffer) + nil)))))) + +(defun yoke-get-file (file &optional _dir) + "Add FILE's directory to `load-dir'. +_DIR is ignored." + (file-name-directory file)) + +(defun yoke-generate-autoloads (package dir) + "Generate autoloads for PACKAGE in DIR." + ;; Shamelessly stolen from `straight'. + (eval-and-compile (require 'autoload)) + (let ((generated-autoload-file + (expand-file-name (format "%s-autoloads.el" package) dir)) + (backup-inhibited t) + (version-control 'never) + (message-log-max nil) + (inhibit-message t)) + (unless (file-exists-p generated-autoload-file) + (let ((find-file-hook nil) + (write-file-functions nil) + (debug-on-error nil) + (left-margin 0)) + (if (fboundp 'make-directory-autoloads) + (make-directory-autoloads dir generated-autoload-file) + (and (fboundp 'update-directory-autoloads) + (update-directory-autoloads dir))))) + (when-let ((buf (find-buffer-visiting generated-autoload-file))) + (kill-buffer buf)) + (load generated-autoload-file :noerror :nomessage) + t)) + +;;; Evaluating forms after features + +(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 eval-after (features &rest body) +(defmacro yoke-eval-after (features &rest body) "Evaluate BODY, but only after loading FEATURES. FEATURES can be an atom or a list; as an atom it works like `with-eval-after-load'. The special feature `init' will evaluate BODY after Emacs is finished initializing." (declare (indent 1) (debug (form def-body))) - (if (eq features 'init) - `(eval-after-init (lambda () ,@body)) - (unless (listp features) - (setf features (list features))) - (if (null features) - (macroexp-progn body) - (let* ((this (car features)) - (rest (cdr features))) - `(with-eval-after-load ',this - (eval-after ,rest ,@body)))))) - -(defun yoke-pkg-name (pkg) - (intern (format "yoke:%s" pkg))) - -(cl-defmacro yoke (pkg - &optional repo - &body body - &key - after ; :after (FEATURE...) - depends ; :depends ((PKG REPO)...) - load ; :load DIRECTORY - (when t whenp) ; :when PREDICATE - (unless nil unlessp) ; :unless PREDICATE - &allow-other-keys) - "Yoke a PKG into your Emacs session." - (declare (indent 2)) - (let ((name (yoke-pkg-name pkg)) - (body (delete2 body - :depends :when :unless :after :load))) - `(cl-block ,name - (condition-case e - (progn - ,@(cond - ((and whenp unlessp) - `((when (or (not ,when) ,unless) - (cl-return-from ,name nil)))) - (whenp `((unless ,when (cl-return-from ,name nil)))) - (unlessp `((when ,unless (cl-return-from ,name nil))))) - ,@(cl-loop for (pkg* repo* load-path*) in depends - collect `(or (yoke-lasso ',pkg* ,repo* ,load-path*) - (cl-return-from ,name nil))) - ,@(cond - (repo `((yoke-lasso ',pkg ,repo ,load))) - (load `((add-to-list 'load-path ,load)))) - ,@(if after - `((eval-after ,after ,@body)) - body)) - (:success ',pkg) - (t (message "%s: %s" ',name e)))))) + (unless (listp features) + (setf features (list features))) + (if (null features) + (macroexp-progn body) + (let* ((this (car features)) + (rest (cdr features))) + (cond ((eq this 'init) + `(yoke--eval-after-init + (lambda () (eval-after ,rest ,@body)))) + (:else + `(with-eval-after-load ',this + (yoke-eval-after ,rest ,@body))))))) -;;; Extras +;;; Integration (defun yoke-imenu-insinuate () "Insinuate `yoke' forms for `imenu'." (require 'imenu) (setf (alist-get "Yoke" imenu-generic-expression nil nil #'equal) - (list (rx (: "(yoke" (+ space) - (group (+ (not space))) + (list (rx (: "(yoke" (+ space) (? "(") + (group (+ (not (or "(" " " "\t" "\n")))) (+ space) (group (+ (not space))))) 1))) -(defun yoke-remove (pkg) - "Remove package PKG from `yoke-dir'." - (interactive (list (completing-read "Package: " - (directory-files yoke-dir) - (lambda (f) - (not (or (string= f ".") - (string= f "..")))) - :require-match))) - (let ((dir (expand-file-name pkg yoke-dir))) - (move-file-to-trash dir) - (message "Package `%s' removed." pkg))) - (provide 'yoke) ;;; yoke.el ends here -- cgit 1.4.1-21-gabe81