diff options
Diffstat (limited to 'fussy.lisp')
| -rw-r--r-- | fussy.lisp | 154 |
1 files changed, 137 insertions, 17 deletions
@@ -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))) |