diff options
| -rw-r--r-- | fussy.asd | 3 | ||||
| -rw-r--r-- | fussy.el | 17 | ||||
| -rw-r--r-- | fussy.lisp | 131 | ||||
| -rw-r--r-- | package.lisp | 5 |
4 files changed, 133 insertions, 23 deletions
@@ -12,6 +12,7 @@ #:dexador #:spinneret #:lass - #:parenscript) + #:parenscript + #:defclass-std) :components ((:file "package") (:file "fussy"))) @@ -1,11 +1,8 @@ (require 'cl-lib) (require 'package) -(defvar +package-name-filter-out-list+ - (list "airline-")) - (defvar +excluded-package-names+ - '(tramp-theme color-theme)) + '(tramp-theme color-theme airline-themes)) (defun fussy-string-ends-with (str suffix) (and (< (length suffix) (length str)) @@ -16,16 +13,14 @@ (let ((name (symbol-name (cl-first pkg-entry)))) (and (or (fussy-string-ends-with name "-theme") (fussy-string-ends-with name "-themes")) - (not (cl-member (cl-first pkg-entry) +excluded-package-names+)) - (cl-notany (lambda (substr) (cl-search substr name)) - +package-name-filter-out-list+)))) + (not (cl-member (cl-first pkg-entry) +excluded-package-names+))))) (defun fussy-themes-packages () (cl-remove-if-not 'fussy-is-theme-p package-archive-contents)) (defun fussy-screenshot-svg (filename) - "Save a screenshot of the current frame as an SVG image. -Saves to a temp file and puts the filename in the kill ring." + "Save a screenshot of the current frame as an SVG image to a file +called filename." (let* ((tmpfile (make-temp-file "Emacs" nil ".svg")) (data (x-export-frames nil 'svg))) (with-temp-file tmpfile @@ -81,15 +76,15 @@ Saves to a temp file and puts the filename in the kill ring." (add-to-list 'package-archives '("melpa" . "https://melpa.org/packages/") t) + (package-initialize) (package-refresh-contents) - (toggle-frame-maximized) - (fussy-generate-all-theme-images "/home/colin/projects/LearnCPP/chapter1/hello_world/hello.cpp" "/home/colin/projects/fussy/fussy.el" "/home/colin/projects/INACTIVE/nsa/nsa.py") (kill-emacs) + @@ -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)) diff --git a/package.lisp b/package.lisp index e90672d..61fb793 100644 --- a/package.lisp +++ b/package.lisp @@ -1,4 +1,7 @@ ;;;; package.lisp (defpackage #:fussy - (:use #:cl)) + (:use #:cl) + (:local-nicknames (#:db #:bknr.datastore) + (#:a #:alexandria-2)) + (:import-from #:defclass-std #:defclass/std)) |