total rewrite of `yoke'

1 files changed, 245 insertions, 150 deletions

@@ -1,184 +1,279 @@
-;;; yoke.el --- yoke packages in to your editing system  -*- lexical-binding: t; -*-
-;; by C. Duckworth <acdw@acdw.net>
-(provide 'yoke)
+;;; yoke.el --- make your editor work for YOU         -*- lexical-binding: t; -*-
+;; Copyright (C) 2022 C. Duckworth <acdw@acdw.net>
+
+;;; 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