update now runs the image generation script

1 files changed, 137 insertions, 17 deletions

diff --git a/fussy.lisp b/fussy.lisp
index d38e511..bfe31a8 100644
--- a/fussy.lisp
+++ b/fussy.lisp
@@ -36,6 +36,7 @@ the emacs' reader readtable."
     keywords
     url
     description
+    contained-themes
     :with))
   (:metaclass db:persistent-class)
   (:documentation "Represents an Emacs theme package."))
@@ -48,7 +49,7 @@ the emacs' reader readtable."
 (defparameter +excludes+
   '(tramp-theme color-theme airline-themes unobtrusive-magit-theme cycle-themes ))
 
-(defun theme-pacakge-p (archive-object)
+(defun theme-package-p (archive-object)
   (when (consp archive-object)
     (unless (member (first archive-object) +excludes+) 
       (let ((name
@@ -91,26 +92,44 @@ the emacs' reader readtable."
        (theme-pkg-authors pkg) (cdr (assoc :authors meta-alist))
        (theme-pkg-keywords pkg) (cdr (assoc :keywords meta-alist))))))
 
-(defun create-db ()
-  (make-instance
-   'db:mp-store
-   :directory (merge-pathnames "fussy-store/" (user-homedir-pathname))
-   :subsystems (list (make-instance 'db:store-object-subsystem))))
 
-(defun start ()
-  (create-db))
+(defvar *update-batch* nil
+  "Collected archive-packages in need of further processing.")
 
 (defun process-archive-theme (archive-theme)
-  (a:if-let (pkg (theme-pkg-with-name (archive-theme-name archive-theme)))
+  ;; ugg this is ugly. I hate it when code is all dense like this.
+  (a:if-let (pkg
+             (theme-pkg-with-name
+              (archive-theme-name archive-theme)))
     (when (not (equalp (archive-theme-version archive-theme)
                        (theme-pkg-version pkg)))
       (update-theme-pkg-from-archive-theme pkg archive-theme))
     (make-theme-pkg-from-archive-theme archive-theme)))
 
-(defun update-themes ()
+(defun mark-theme-to-update (archive-theme)
+  (a:if-let (pkg
+             (theme-pkg-with-name
+              (archive-theme-name archive-theme)))
+    (when (not (equalp (archive-theme-version archive-theme)
+                       (theme-pkg-version pkg)))
+      (push archive-theme *update-batch*))
+    (push archive-theme *update-batch*)))   ;; 🤮
+
+
+(defun update-theme-packages ()
   (let ((all-themes-from-archive
-          (remove-if-not #'theme-pacakge-p (fetch-emacs-archive))))
+          (remove-if-not #'theme-package-p (fetch-emacs-archive)))
+        (*update-batch* nil))
     (dolist (archive-theme all-themes-from-archive)
+      (mark-theme-to-update archive-theme))
+
+    ;; just going to let this throw an error. will either introduce a
+    ;; restart-case with some restarts or something later, or will
+    ;; just catch the error in the caller of update-theme-packages
+    (generate-images-for-packages
+     (mapcar #'archive-theme-name *update-batch*))
+    ;; if we didn't error: update the db
+    (dolist (archive-theme *update-batch*)
       (process-archive-theme archive-theme))))
 
 (defun all-theme-keywords ()
@@ -125,19 +144,120 @@ the emacs' reader readtable."
                        :test #'string-equal)
           :collect theme))
 
-(defun all-themes ()
+(defun all-theme-packages ()
   (db:store-objects-with-class 'theme-pkg))
 
+(defun just-the-directory-namestring (path)
+  "returns a string, the name of the directory that the path represents."
+  ;; directory-namestring is taken, seems to peel off any file at the end
+  (first (last (pathname-directory path))))
+
+
+(defun themes-in-package (pkg &optional (config *config*))
+  "Themes that belong to a particular package are stored as the names of
+directories that contain the theme's images. These directories are
+stored beneath the directory that names the package.  This function
+returns a list of those names."
+  (mapcar #'just-the-directory-namestring
+          (uiop:subdirectories
+           (uiop:merge-pathnames*
+            (string-downcase (format nil "~a/" (theme-pkg-name pkg)))
+            (full-theme-image-directory config)))))
+
+(defun all-themes ()
+  (a:mappend #'themes-in-package (all-theme-packages)))
+
 (defun theme-mentions-anywhere (term)
   (lambda (theme)
-    (with-slots (name keywords description authors maintainer) theme
-      (or (search term (symbol-name name) :test #'char-equal)
-          (some (lambda (keyword) (search term keyword :test #'char-equal)) keywords)
-          (search term description :test #'char-equal)))))
+    (if (stringp theme)
+        (search term theme)
+        (with-slots (name keywords description authors maintainer) theme
+          (or (search term (symbol-name name) :test #'char-equal)
+              (some (lambda (keyword) (search term keyword :test #'char-equal)) keywords)
+              (search term description :test #'char-equal))))))
 
 (defun search-themes (&rest terms)
   (remove-if-not
    (apply #'a:conjoin (mapcar #'theme-mentions-anywhere terms))
-   (all-themes)))
+   (all-theme-packages)))
+
+(defclass/std config ()
+  ((theme-image-directory
+    store-directory
+    fussy-el
+    :std ""
+    :documentation "These paths are by default equal to the config directory.")))
+
+
+(defvar *config* nil)
+(defvar *config-directory* nil
+  "The config dir is the directory where the config file is. This
+directory is used as a default directory for all relative paths
+mentioned in the config file. Any Absolute paths in the config file
+are treated as such.")
+
+(defun load-config-from-file (file)
+  (apply #'make-instance
+         'config
+         (read-from-string (a:read-file-into-string file))))
+
+(defun full-store-directory (&optional (config *config*))
+  (uiop:merge-pathnames* (store-directory config) *config-directory*))
+
+(defun full-theme-image-directory (&optional (config *config*))
+  (uiop:merge-pathnames* (theme-image-directory config) *config-directory*))
+
+(defun create-db ()
+  (unless (boundp 'db:*store* )
+    (ensure-directories-exist (full-store-directory))
+    (make-instance
+     'db:mp-store
+     :directory (full-store-directory)
+     :subsystems (list (make-instance 'db:store-object-subsystem)))))
+
+(defun start (&key config-file)
+  (unless config-file
+    (setf config-file
+          (or (uiop:getenv "FUSSY_CONFIG")
+              (asdf:system-relative-pathname :fussy "files/config.sexp"))))
+  (setf *config*
+        (load-config-from-file config-file)
+        *config-directory*
+        (uiop:pathname-directory-pathname config-file))
+  (create-db)
+  (update-theme-packages))
+
+
+(defparameter +standard-themes+
+  '(adwaita deeper-blue dichromacy light-blue modus-operandi modus-vivendi tango-dark
+    wheatgrass manoj-dark tsdh-dark tsdh-light whiteboard
+    leuven misterioso tango wombat)
+  "these are built in themes - this list can be passed to the image
+generation script when you want to generate themes for just a single
+package - ordinarily the script generates images for all themes, but
+passing this list as the value of FUSSY-EXCLUDED-THEMES will ensure
+that they are not loaded during image gen.")
+
+
+(defun generate-elisp-to-fetch-and-exclude (package-names)
+  (let ((downcaser
+          (a:compose #'string-downcase #'symbol-name)))
+    (format nil "(setq fussy-themes-packages '(~{~a~^ ~}) fussy-excluded-themes '(~{~a~^ ~}))"
+            (mapcar downcaser package-names)
+            (mapcar downcaser +standard-themes+))))
+
+(defun fussy-elisp-script-location (&optional (config *config*))
+  (uiop:merge-pathnames* *config-directory* (fussy-el config)))
+
+(defun format-emacs-evocation-script (package-names)
+  (format
+   nil
+   "env HOME=~a emacs -q --eval ~s --load ~a"
+   (full-theme-image-directory)
+   (generate-elisp-to-fetch-and-exclude package-names)
+   (fussy-elisp-script-location)))
 
 
+(defun generate-images-for-packages (package-names)
+  (uiop:launch-program
+   (format-emacs-evocation-script package-names)))