blob: d38e5115332b11c4842a13669fe96857ef99fc86 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
;;;; 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)))
|
