diff options
Diffstat (limited to 'fussy.lisp')
| -rw-r--r-- | fussy.lisp | 131 |
1 files changed, 121 insertions, 10 deletions
@@ -1,11 +1,12 @@ ;;;; fussy.lisp (in-package #:fussy) - (defvar +default-emacs-package-archive+ "https://melpa.org/packages/archive-contents") (defun emacs-reader-readtable () + "Return a readtable that will read the emacs package archive +contents." (let ((*readtable* (copy-readtable nil))) (labels ((bracket-reader (stream char) (declare (ignorable char)) @@ -14,19 +15,129 @@ (set-macro-character #\] (get-macro-character #\) nil)) *readtable*))) - (defun fetch-emacs-archive (&optional (archive +default-emacs-package-archive+)) + "Fetch the package archive from ARCHIVE, a url, and read it in using +the emacs' reader readtable." + ;; TODO: HANDLE HTTP ERRORS, HANDLE TIMEOUT, HANDLE READ ERRORS (multiple-value-bind (stream status) (dexador:get archive :want-stream t) (when (= 200 status) (let ((*readtable* (emacs-reader-readtable))) (read stream))))) -(defun package-name-mentions (str) - (lambda (package) - (when (consp package) - (let ((string-name - (symbol-name (first package)))) - (search str string-name :test #'char-equal))))) +(defclass/std theme-pkg (db:store-object) + ((name + :with + :index-type bknr.indices:unique-index + :index-reader theme-pkg-with-name) + (commit + version + authors + maintainer + keywords + url + description + :with)) + (:metaclass db:persistent-class) + (:documentation "Represents an Emacs theme package.")) + +(defmethod print-object ((theme theme-pkg) stream) + (format stream "#<THEME-PKG ~a ~a>" + (theme-pkg-name theme) + (theme-pkg-version theme))) + +(defparameter +excludes+ + '(tramp-theme color-theme airline-themes unobtrusive-magit-theme cycle-themes )) + +(defun theme-pacakge-p (archive-object) + (when (consp archive-object) + (unless (member (first archive-object) +excludes+) + (let ((name + (symbol-name (first archive-object)))) + (or (a:ends-with-subseq "-theme" name :test #'char-equal) + (a:ends-with-subseq "-themes" name :test #'char-equal)))))) + +(defun archive-theme-name (archive-pkg) + (first archive-pkg)) + +(defun archive-theme-version (archive-pkg) + (second archive-pkg)) + +(defun make-theme-pkg-from-archive-theme (archive-theme) + (destructuring-bind (name version _dontcare desc _dontcare2 meta-alist) archive-theme + (declare (ignore _dontcare _dontcare2)) + (db:with-transaction () + (make-instance + 'theme-pkg + :name name + :version version + :description desc + :commit (cdr (assoc :commit meta-alist)) + :maintainer (cdr (assoc :maintainer meta-alist)) + :url (cdr (assoc :url meta-alist)) + :authors (cdr (assoc :authors meta-alist)) + :keywords (cdr (assoc :keywords meta-alist)))))) + +(defun update-theme-pkg-from-archive-theme (pkg arch) + (destructuring-bind (name version _dontcare desc _dontcare2 meta-alist) arch + (declare (ignore _dontcare _dontcare2)) + (db:with-transaction () + (setf + (theme-pkg-name pkg) name + (theme-pkg-version pkg) version + (theme-pkg-description pkg) desc + (theme-pkg-commit pkg) (cdr (assoc :commit meta-alist)) + (theme-pkg-maintainer pkg) (cdr (assoc :maintainer meta-alist)) + (theme-pkg-url pkg) (cdr (assoc :url meta-alist)) + (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)) + +(defun process-archive-theme (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))) + (update-theme-pkg-from-archive-theme pkg archive-theme)) + (make-theme-pkg-from-archive-theme archive-theme))) + +(defun update-themes () + (let ((all-themes-from-archive + (remove-if-not #'theme-pacakge-p (fetch-emacs-archive)))) + (dolist (archive-theme all-themes-from-archive) + (process-archive-theme archive-theme)))) + +(defun all-theme-keywords () + (delete-duplicates + (copy-seq (mapcan (a:compose #'copy-seq #'theme-pkg-keywords) + (db:store-objects-with-class 'theme-pkg))) + :test #'equal)) + +(defun themes-with-keywords (&rest keywords) + (loop :for theme :in (db:store-objects-with-class 'theme-pkg) + :when (subsetp keywords (theme-pkg-keywords theme) + :test #'string-equal) + :collect theme)) + +(defun all-themes () + (db:store-objects-with-class 'theme-pkg)) + +(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))))) + +(defun search-themes (&rest terms) + (remove-if-not + (apply #'a:conjoin (mapcar #'theme-mentions-anywhere terms)) + (all-themes))) + -(defun find-themes (archive-contents) - (remove-if-not (package-name-mentions "-theme") archive-contents)) |