Just hackin'

4 files changed, 133 insertions, 23 deletions

diff --git a/fussy.asd b/fussy.asd
index 8c7b6fe..783f83e 100644
--- a/fussy.asd
+++ b/fussy.asd
@@ -12,6 +12,7 @@
                #:dexador
                #:spinneret
                #:lass
-               #:parenscript)
+               #:parenscript
+               #:defclass-std)
   :components ((:file "package")
                (:file "fussy")))
diff --git a/fussy.el b/fussy.el
index 2ca2432..9508661 100644
--- a/fussy.el
+++ b/fussy.el
@@ -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)
+
diff --git a/fussy.lisp b/fussy.lisp
index 9173e0a..d38e511 100644
--- a/fussy.lisp
+++ b/fussy.lisp
@@ -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))