;;;; 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))
               (read-delimited-list #\] stream)))
      (set-macro-character #\[ #'bracket-reader)
      (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)))))

(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)))