[radian-software#103] Add straight-x.el, asynchronous package fetch

.gitignore

@@ -1,3 +1 @@
-/bootstrap.elc
-/install.elc
-/straight.elc
+*.elc

bootstrap.el

@@ -82,7 +82,7 @@
 ;; Then we register (and build) straight.el itself.
 (straight-use-package `(straight :type git :host github
                                  :repo "raxod502/straight.el"
-                                 :files ("straight.el")
+                                 :files ("straight.el" "straight-x.el")
                                  :branch ,straight-repository-branch))
 
 ;;; bootstrap.el ends here

straight-x.el

@@ -0,0 +1,133 @@
+;;; straight-x.el --- Experimental extensions. -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018 Radon Rosborough and contributors
+
+;; Author: Radon Rosborough <radon.neon@gmail.com>
+;; Created: 1 Jan 2017
+;; Homepage: https://github.com/raxod502/straight.el
+;; Keywords: extensions
+;; Package-Requires: ((emacs "24.4"))
+;; Version: 1.0
+
+;;; Commentary:
+
+;; This file contains experimental extensions to straight.el which are
+;; not yet ready for direct inclusion. No guarantees are made about
+;; the behavior of code in this file.
+
+;; See straight.el for more information.
+
+;;; Code:
+
+(require 'straight)
+
+(require 'cl-lib)
+(require 'subr-x)
+
+(defun straight-x-existing-repos ()
+  (let (recipes)
+    (straight--map-repos
+     (lambda (recipe)
+       (when (and (plist-get recipe :local-repo)
+                  (straight--repository-is-available-p recipe))
+         (push recipe recipes))))
+    (nreverse recipes)))
+
+(defvar straight-x-all nil)
+(defvar straight-x-waiting nil)
+(defvar straight-x-running nil)
+(defvar straight-x-finished nil)
+
+(defvar straight-x-buffer "*straight*")
+
+(defun straight-x-buffer-header-line ()
+  (with-current-buffer straight-x-buffer
+    (let ((finished (length straight-x-finished))
+          (all (length straight-x-all)))
+      (setq header-line-format
+            (format "Fetching %d/%d...%s"
+                    finished all (if (= finished all) "Done" ""))))))
+
+(defun straight-x-buffer-line (linum new-string)
+  (with-current-buffer straight-x-buffer
+    (goto-char (point-min))
+    (forward-line (1- linum))
+    (delete-region (line-beginning-position) (line-end-position))
+    (insert new-string)))
+
+(defun straight-x-when-done (process _change)
+  ;; Assuming success
+  (let* ((recipe (process-get process :recipe))
+         (package (plist-get recipe :package))
+         (linum (1+ (cl-position recipe straight-x-all :test #'equal))))
+    (setq straight-x-running (delete recipe straight-x-running)
+          straight-x-finished (cons recipe straight-x-finished))
+    (straight-x-buffer-line
+     linum
+     (format "+ %s: %s"
+             (propertize package 'face 'font-lock-keyword-face)
+             (if (process-get process :up-to-date)
+                 "Already up to date"
+               "Updated")))
+    (straight-x-buffer-header-line))
+  (kill-buffer (process-buffer process))
+  (straight-x-start-process))
+
+(defun straight-x-strip (string)
+  ;; git clone/fetch --progress
+  (car (last (split-string string (rx (or ?\r ?\n)) t " +"))))
+
+(defun straight-x-filter (process output)
+  (let* ((recipe (process-get process :recipe))
+         (linum (1+ (cl-position recipe straight-x-all :test #'equal))))
+    (process-put process :up-to-date nil)
+    (straight-x-buffer-line
+     linum
+     (format "- %s: %s"
+             (propertize
+              (plist-get recipe :package)
+              'face 'font-lock-variable-name-face)
+             (straight-x-strip output)))))
+
+(defun straight-x-start-process ()
+  (when-let* ((recipe (pop straight-x-waiting)))
+    (push recipe straight-x-running)
+    (straight--with-plist recipe
+        (local-repo package)
+      (let ((proc (let* ((default-directory (straight--repos-dir local-repo))
+                         (process-connection-type nil)
+                         (name (format " *straight %s*" package))
+                         (buf (generate-new-buffer name)))
+                    (start-process name buf "git" "fetch"))))
+        (process-put proc :recipe recipe)
+        (process-put proc :up-to-date t)
+        (set-process-filter proc #'straight-x-filter)
+        (set-process-sentinel proc #'straight-x-when-done)))))
+
+(defvar straight-x-process-limit 10)
+
+(defun straight-x-fetch-all ()
+  (interactive)
+  (setq straight-x-all (straight-x-existing-repos)
+        straight-x-waiting straight-x-all
+        straight-x-running nil
+        straight-x-finished nil)
+  (with-current-buffer (get-buffer-create straight-x-buffer)
+    (display-buffer (current-buffer))
+    (erase-buffer)
+    (straight-x-buffer-header-line)
+    (insert (make-string (length straight-x-all) ?\n))
+    (cl-loop for recipe in straight-x-all
+             for linum from 1
+             do (straight-x-buffer-line
+                 linum
+                 (format "- %s: Waiting"
+                         (propertize
+                          (plist-get recipe :package)
+                          'face 'font-lock-variable-name-face)))))
+  (dotimes (_ straight-x-process-limit)
+    (straight-x-start-process)))
+
+(provide 'straight-x)
+
+;;; straight-x.el ends here

straight.el

@@ -1,6 +1,6 @@
 ;;; straight.el --- Next-generation package manager. -*- lexical-binding: t -*-
 
-;; Copyright (C) 2017 Radon Rosborough
+;; Copyright (C) 2018 Radon Rosborough and contributors
 
 ;; Author: Radon Rosborough <radon.neon@gmail.com>
 ;; Created: 1 Jan 2017