git.fiddlerwoaroof.com
Browse code

Refactoring colorscheme stuff out of the RSS reader

fiddlerwoaroof authored on 03/09/2015 13:58:42
Showing 5 changed files
1 1
new file mode 100644
... ...
@@ -0,0 +1 @@
1
+This is the stub README.txt for the "colors" project.
0 2
new file mode 100644
... ...
@@ -0,0 +1,9 @@
1
+;;;; colors.asd
2
+
3
+(asdf:defsystem #:colors
4
+  :description "Describe colors here"
5
+  :author "Your Name <your.name@example.com>"
6
+  :license "Specify license here"
7
+  :serial t
8
+  :components ((:file "colors")))
9
+
0 10
new file mode 100644
... ...
@@ -0,0 +1,111 @@
1
+;;;; colors.lisp
2
+(defpackage #:colors
3
+  (:use #:cl)
4
+  (:export #:colorscheme #:palette *palette*
5
+           #:invert-palette
6
+           #:let-palette #:with-palette
7
+           #:accentize
8
+           #:colorscheme-bg #:colorscheme-bg-highlight 
9
+           #:colorscheme-fg-deemph #:colorscheme-fg #:colorscheme-fg-highlight 
10
+           #:colorscheme-accent 
11
+           #:colorscheme-hover-highlight))
12
+
13
+(in-package #:colors)
14
+(declaim (optimize (debug 2) (safety 2) (speed 0)))
15
+
16
+;;; Generic utility macro TODO: separate these out!!!
17
+(defmacro initialize-to (obj1-v obj2-v &body slot-swaps)
18
+  (alexandria:with-gensyms (obj1 obj2)
19
+    `(let* ((,obj1 ,obj1-v)
20
+            (,obj2 ,obj2-v))
21
+       ,@(loop for (to from) in slot-swaps
22
+               collect `(setf (,to ,obj1) (,from ,obj2))))))
23
+
24
+;;; This macro connects the "-" prefixed slots in the colorscheme class
25
+;;; To the appropriate palette
26
+(defmacro def-palette-accessor (scheme-slot scheme palette )
27
+  `(progn
28
+     (defgeneric ,scheme-slot (,scheme))
29
+     (defmethod ,scheme-slot ((,scheme colorscheme))
30
+       (slot-value ,palette (,(intern (concatenate 'string "-" (symbol-name scheme-slot))) ,scheme)))))
31
+
32
+
33
+;; &group interfaces
34
+;;; Palette class and methods &group
35
+
36
+(defclass palette () ; solarized http://ethanschoonover.com/solarized
37
+  ((base03     :accessor palette-base03      :initform "#002b36")
38
+   (base02     :accessor palette-base02      :initform "#073642")
39
+   (base01     :accessor palette-base01      :initform "#586e75")
40
+   (base00     :accessor palette-base00      :initform "#657b83")
41
+   (base0      :accessor palette-base0       :initform "#839496")
42
+   (base1      :accessor palette-base1       :initform "#93a1a1")
43
+   (base2      :accessor palette-base2       :initform "#eee8d5")
44
+   (base3      :accessor palette-base3       :initform "#fdf6e3")
45
+   (yellow     :accessor palette-yellow      :initform "#b58900")
46
+   (orange     :accessor palette-orange      :initform "#cb4b16")
47
+   (red        :accessor palette-red         :initform "#dc322f")
48
+   (magenta    :accessor palette-magenta     :initform "#d33682")
49
+   (violet     :accessor palette-violet      :initform "#6c71c4")
50
+   (blue       :accessor palette-blue        :initform "#268bd2")
51
+   (cyan       :accessor palette-cyan        :initform "#2aa198")
52
+   (green      :accessor palette-green       :initform "#859900")))
53
+
54
+(defgeneric invert-palette (palette))
55
+
56
+;;; The palette var: this defaults to the solarized palette defined
57
+;;; above, but can (and should) be temporarily rebound via the 
58
+;;; with-palette macro below.
59
+(defparameter *palette* (make-instance 'palette))
60
+
61
+(defmacro let-palette (palette &body body)
62
+  "Set custom palette in end-user code"
63
+  `(let ((*palette* ,palette))
64
+     ,@body))
65
+
66
+(defmacro with-palette ((place) &body body)
67
+  "Access the current palette"
68
+  `(let ((,place *palette*))
69
+     ,@body))
70
+
71
+;;; &endgroup
72
+;;; &group Color scheme
73
+(defclass colorscheme ()
74
+  ((bg           :accessor -colorscheme-bg           :initform 'base03)
75
+   (bg-highlight :accessor -colorscheme-bg-highlight :initform 'base02)
76
+   (fg-deemph    :accessor -colorscheme-fg-deemph    :initform 'base01)
77
+   (fg           :accessor -colorscheme-fg           :initform 'base0 )
78
+   (fg-highlight :accessor -colorscheme-fg-highlight :initform 'base1 )
79
+   (hover-highlight :accessor -colorscheme-hover-highlight :initform 'base3 )
80
+   (accent       :accessor -colorscheme-accent       :initform 'violet)))
81
+
82
+(defgeneric accentize (colorscheme accent))
83
+
84
+(def-palette-accessor colorscheme-bg               scheme *palette*)
85
+(def-palette-accessor colorscheme-bg-highlight     scheme *palette*)
86
+(def-palette-accessor colorscheme-fg-deemph        scheme *palette*)
87
+(def-palette-accessor colorscheme-fg               scheme *palette*)
88
+(def-palette-accessor colorscheme-fg-highlight     scheme *palette*)
89
+(def-palette-accessor colorscheme-accent           scheme *palette*)
90
+(def-palette-accessor colorscheme-hover-highlight  scheme *palette*)
91
+
92
+;;; &endgroup
93
+;; &endgroup
94
+
95
+(defmethod invert-palette ((palette palette))
96
+  (let ((result (make-instance 'palette)))
97
+    (initialize-to result palette
98
+      (palette-base03 palette-base3)
99
+      (palette-base02 palette-base2)
100
+      (palette-base01 palette-base1)
101
+      (palette-base00 palette-base0)
102
+      (palette-base0  palette-base00)
103
+      (palette-base1  palette-base01)
104
+      (palette-base2  palette-base02)
105
+      (palette-base3  palette-base03))
106
+    result))
107
+
108
+(defmethod accentize ((colorscheme colorscheme) accent)
109
+  (setf (colorscheme-accent colorscheme) (funcall accent colorscheme)))
110
+
111
+; vim: foldmethod=marker foldmarker=&group,&endgroup foldlevel=0 :
0 112
new file mode 100644
... ...
@@ -0,0 +1,2 @@
1
+;;;; package.lisp
2
+
... ...
@@ -1,9 +1,12 @@
1 1
 (in-package :cl-user)
2
-(ql:quickload :cl-oid-connect)
3 2
 (ql:quickload :plump)
3
+(ql:quickload :lquery)
4 4
 (ql:quickload :cl-markup)
5
+(ql:quickload :cl-oid-connect)
6
+(ql:quickload :colors)
5 7
 
6 8
 (push (cons "application" "rdf+xml") drakma:*text-content-types*)
9
+(push (cons "application" "rss+xml") drakma:*text-content-types*)
7 10
 (push (cons "text" "rss+xml") drakma:*text-content-types*)
8 11
 
9 12
 (defparameter *app* (make-instance 'ningle:<app>))
... ...
@@ -59,12 +62,20 @@
59 62
     (let* ((result (make-instance 'rss-item :item item))
60 63
            (title (extract-text "title"))
61 64
            (link (extract-text "link"))
65
+           (content-encoded (lquery:$ (children) (tag-name "content:encoded")))
66
+
67
+           (description-element (if (= 0 (length content-encoded))
68
+                                  (lquery:$ (children "description"))
69
+                                  content-encoded))
70
+
62 71
            (description-raw (let ((plump:*html-tags*)
63 72
                                   (ss (make-string-output-stream)))
64
-                              (plump:serialize
65
-                                (plump:parse (extract-text "description"))
66
-                                ss)
67
-                              (get-output-stream-string ss)))
73
+                              (if (= 0 (length description-element))
74
+                                ""
75
+                                (progn
76
+                                  (plump:serialize (plump:parse (plump:text (elt description-element 0))) ss)
77
+                                  (get-output-stream-string ss)))))
78
+
68 79
            (description-munged (dehtml (extract-text "description")))
69 80
            (category (get-category-names (lquery:$ "category")))
70 81
            ;(comments)
... ...
@@ -114,16 +125,25 @@
114 125
           :class "login-button google"
115 126
           (:a :href "/login/google" "Google"))))))
116 127
 
128
+(lquery:define-lquery-list-function tag-name (nodes &rest tags)
129
+  "Manipulate elements on the basis of there tag-name.
130
+   With no arguments, return their names else return
131
+   the corresponding tags."
132
+  (if (null tags)
133
+    (map 'vector #'plump:tag-name nodes)
134
+    (apply #'vector
135
+           (loop for node across nodes
136
+                 if (find (plump:tag-name node) tags :test #'string=) 
137
+                 collect node))))
138
+
117 139
 (defparameter *feed-urls*
118 140
   #(
119 141
     "http://www.reddit.com/r/lisp.rss"
120 142
     "http://www.reddit.com/r/scheme.rss"
121 143
     "http://www.reddit.com/r/prolog.rss"
122 144
     "http://www.reddit.com/r/haskell.rss"
123
-    "http://www.reddit.com/r/roguelikedev.rss"
124
-    "http://www.reddit.com/r/roguelikes.rss"
125 145
     "http://www.reddit.com/r/talesfromtechsupport.rss"
126
-    "https://thomism.wordpress.com/feed/rss"
146
+    "https://drmeister.wordpress.com/feed/rss"
127 147
     ))
128 148
 
129 149
 (let
... ...
@@ -137,175 +157,109 @@
137 157
 
138 158
 (defparameter *feeds* (map 'vector (lambda (x) (unwind-protect (make-rss-feed x))) *docs*))
139 159
 
140
-(defclass palette () ; soloarized http://ethanschoonover.com/solarized
141
-  ((base03     :accessor palette-base03      :initform "#002b36")
142
-   (base02     :accessor palette-base02      :initform "#073642")
143
-   (base01     :accessor palette-base01      :initform "#586e75")
144
-   (base00     :accessor palette-base00      :initform "#657b83")
145
-   (base0      :accessor palette-base0       :initform "#839496")
146
-   (base1      :accessor palette-base1       :initform "#93a1a1")
147
-   (base2      :accessor palette-base2       :initform "#eee8d5")
148
-   (base3      :accessor palette-base3       :initform "#fdf6e3")
149
-   (yellow     :accessor palette-yellow      :initform "#b58900")
150
-   (orange     :accessor palette-orange      :initform "#cb4b16")
151
-   (red        :accessor palette-red         :initform "#dc322f")
152
-   (magenta    :accessor palette-magenta     :initform "#d33682")
153
-   (violet     :accessor palette-violet      :initform "#6c71c4")
154
-   (blue       :accessor palette-blue        :initform "#268bd2")
155
-   (cyan       :accessor palette-cyan        :initform "#2aa198")
156
-   (green      :accessor palette-green       :initform "#859900")))
157
-
158
-(defparameter *palette* (make-instance 'palette))
159
-(defgeneric invert-palette (palette))
160
-
161
-(defmacro initialize-to (obj1-v obj2-v &body slot-swaps)
162
-  (alexandria:with-gensyms (obj1 obj2)
163
-    `(let* ((,obj1 ,obj1-v)
164
-            (,obj2 ,obj2-v))
165
-       ,@(loop for (to from) in slot-swaps
166
-               collect `(setf (,to ,obj1) (,from ,obj2))))))
167
-
168
-(defmethod invert-palette ((palette palette))
169
-  (let ((result (make-instance 'palette)))
170
-    (initialize-to result palette
171
-      (palette-base03 palette-base3)
172
-      (palette-base02 palette-base2)
173
-      (palette-base01 palette-base1)
174
-      (palette-base00 palette-base0)
175
-      (palette-base0  palette-base00)
176
-      (palette-base1  palette-base01)
177
-      (palette-base2  palette-base02)
178
-      (palette-base3  palette-base03))
179
-    result))
180
-(setf *palette* (invert-palette *palette*))
181
-
182
-(defclass colorscheme ()
183
-  ((bg           :accessor -colorscheme-bg           :initform 'base03)
184
-   (bg-highlight :accessor -colorscheme-bg-highlight :initform 'base02)
185
-   (fg-deemph    :accessor -colorscheme-fg-deemph    :initform 'base01)
186
-   (fg           :accessor -colorscheme-fg           :initform 'base0 )
187
-   (fg-highlight :accessor -colorscheme-fg-highlight :initform 'base1 )
188
-   (accent       :accessor -colorscheme-accent       :initform 'violet)))
189
-
190
-(defgeneric accentize (colorscheme accent))
191
-(defmethod accentize ((colorscheme colorscheme) accent)
192
-  (setf (colorscheme-accent colorscheme) (funcall accent colorscheme)))
193
-
194
-(defmacro def-palette-accessor (scheme-slot scheme palette )
195
-  `(progn
196
-     (defgeneric ,scheme-slot (,scheme))
197
-     (defmethod ,scheme-slot ((,scheme colorscheme))
198
-       (slot-value ,palette (,(intern (concatenate 'string "-" (symbol-name scheme-slot))) ,scheme)))))
199
-
200
-(def-palette-accessor colorscheme-bg scheme *palette*)
201
-(def-palette-accessor colorscheme-bg-highlight scheme *palette*)
202
-(def-palette-accessor colorscheme-fg-deemph scheme *palette*)
203
-(def-palette-accessor colorscheme-fg scheme *palette*)
204
-(def-palette-accessor colorscheme-fg-highlight scheme *palette*)
205
-(def-palette-accessor colorscheme-accent scheme *palette*)
206
-
207
-(defgeneric rebase (colorscheme))
208
-(defmethod rebase ((colorscheme colorscheme))
209
-  (macrolet
210
-    ((swap-color (obj slot color1 color2)
211
-       `(setf (,slot ,obj)
212
-             (if (string= (,slot ,obj) (,color1 ,obj))
213
-               (,color2 ,obj)
214
-               (,color1 ,obj)))))
215
-    ; Note that swap-color doesn't use gensyms: so don't run functions in invocation
216
-    (swap-color colorscheme colorscheme-accent colorscheme-base1 colorscheme-base01)
217
-    (swap-color colorscheme colorscheme-bg colorscheme-base3 colorscheme-base03)
218
-    (swap-color colorscheme colorscheme-bg-highlight colorscheme-base3 colorscheme-base03)
219
-    (swap-color colorscheme colorscheme-deemph colorscheme-base0 colorscheme-base0)
220
-    (swap-color colorscheme colorscheme-fg colorscheme-base0 colorscheme-base0)
221
-    (swap-color colorscheme colorscheme-fg-highlight colorscheme-base0 colorscheme-base0)
222
-    colorscheme))
223
-
224
-
225
-(defparameter *colorscheme* (make-instance 'colorscheme))
226
-(rebase *colorscheme*)
227
-(accentize *colorscheme* #'colorscheme-blue)
228
-
229
-;rebase  $base3, $base2, $base1, $base0,$base00,$base01,$base02,$base03
230
-;rebase $base03,$base02,$base01,$base00 ,$base0 ,$base1 ,$base2 ,$base3
231
-
160
+;;; this will be bound by calls to with-palette
161
+;;; probably should be refactored out
162
+(defparameter *palette* nil)
232 163
 
164
+(defparameter *colorscheme* (make-instance 'colors:colorscheme))
233 165
 
234 166
 (cl-oid-connect:def-route ("/theme/dark.css" (params) :app *app*)
235
-  (let ((*palette* (make-instance 'palette)))
167
+  (colors:let-palette (make-instance 'colors:palette)
236 168
     (eval '(get-theme-css))))
237 169
 
238 170
 (cl-oid-connect:def-route ("/theme/light.css" (params) :app *app*)
239
-  (let ((*palette* (invert-palette (make-instance 'palette))))
171
+  (colors:let-palette (colors:invert-palette (make-instance 'colors:palette))
240 172
     (eval '(get-theme-css))))
241 173
 
242 174
 (defun get-theme-css ()
243
-  (flet ((combine-unit-q (quant unit) (format nil "~d~a" quant unit)))
244
-    (let* ((header-height 19)
245
-           (height-units "vh")
246
-           (ss (lass:compile-and-write
247
-                 `(* :color ,(colorscheme-fg *colorscheme*))
175
+  (colors:with-palette (*palette*)
176
+    (flet ((combine-unit-q (quant unit) (format nil "~d~a" quant unit)))
177
+      (let* ((header-height 9)
178
+             (height-units "vh")
179
+             (ss (lass:compile-and-write
180
+                   `(* :color ,(colors:colorscheme-fg *colorscheme*))
248 181
 
249
-                 `(body :background-color ,(colorscheme-bg *colorscheme*))
182
+                 `(body :background-color ,(colors:colorscheme-bg *colorscheme*))
250 183
 
251 184
                  `((:or h1 h2 h3)
252
-                   :color ,(colorscheme-fg-highlight *colorscheme*))
185
+                   :color ,(colors:colorscheme-fg-highlight *colorscheme*))
253 186
                  `(.feed-header
254
-                    :background-color ,(colorscheme-bg-highlight *colorscheme*))
187
+                    :background-color ,(colors:colorscheme-bg-highlight *colorscheme*))
255 188
 
256
-                 `((:or h4 h5 h6) :color ,(colorscheme-fg-highlight *colorscheme*))
189
+                 `((:or h4 h5 h6) :color ,(colors:colorscheme-fg-highlight *colorscheme*))
257 190
 
258 191
                  `(header
259
-                    :border-bottom "thin" "solid" ,(colorscheme-accent *colorscheme*)
192
+                    :border-bottom "thin" "solid" ,(colors:colorscheme-accent *colorscheme*)
260 193
                     :height ,(combine-unit-q header-height height-units)
261 194
                     :font-size ,(combine-unit-q (* 0.75 header-height) height-units)
262 195
                     :line-height ,(combine-unit-q header-height height-units)
263 196
                     (.flip-button
264
-                      :float right))
197
+                      :float right
198
+                      :width "3em"
199
+                      :height "3em"
200
+                      :padding-left "1em"
201
+                      :padding-bottom "1em"
202
+                      :border-bottom-left-radius "100%"
203
+                      :border none
204
+                      :transition "all 0.5s ease"
205
+                      :background-color ,(colors:colorscheme-fg *colorscheme*)
206
+                      :color ,(colors:colorscheme-bg *colorscheme*))
207
+                    ((:and .flip-button :focus)
208
+                     :outline none)
209
+                    ((:and .flip-button :hover)
210
+                     :width "4em"
211
+                     :height "4em"
212
+                     :padding-left "2em"
213
+                     :padding-bottom "2em")
214
+                    )
265 215
 
266 216
                  `(main
267
-                    :border-left thin solid ,(colorscheme-accent *colorscheme*)
217
+                    :border-left thin solid ,(colors:colorscheme-accent *colorscheme*)
268 218
                     :height ,(combine-unit-q (- 100 header-height) height-units))
269 219
 
270 220
                  `((:or a (:and a :visited) (:and a :active) code.url)
271
-                   :color ,(colorscheme-fg-highlight *colorscheme*))
221
+                   :color ,(colors:colorscheme-fg-highlight *colorscheme*))
272 222
 
273 223
                  `(section#sidebar
274 224
                     (ul.menu
275 225
                       ((li + li)
276
-                       :border-top "thin" "solid" ,(colorscheme-fg-highlight *colorscheme*))
226
+                       :border-top "thin" "solid" ,(colors:colorscheme-fg-highlight *colorscheme*))
277 227
                       ((:and li :hover)
278
-                       :background-color ,(colorscheme-bg-highlight *colorscheme*)
279
-                       :color ,(colorscheme-fg-highlight *colorscheme*))))
228
+                       :background-color ,(colors:colorscheme-hover-highlight *colorscheme*)
229
+                       :color ,(colors:colorscheme-fg-highlight *colorscheme*))))
280 230
 
281 231
                  `(.feed
282
-                    :border-bottom thin solid ,(colorscheme-fg *colorscheme*)
232
+                    :border-bottom thin solid ,(colors:colorscheme-fg *colorscheme*)
283 233
                     :border-left none)
284 234
 
235
+                 `(.link-header :background-color ,(colors:colorscheme-bg-highlight *colorscheme*))
285 236
                  `(.link
286
-                    :border-top thin solid ,(colorscheme-fg *colorscheme*)
237
+                    :border-top thin solid ,(colors:colorscheme-fg *colorscheme*)
287 238
                     :border-bottom none
288 239
 
289
-                    (.link-header :background-color ,(colorscheme-bg-highlight *colorscheme*))
290 240
 
291 241
                     (.link-info
292
-                      :color ,(colorscheme-fg-deemph *colorscheme*)
293
-                      :border-bottom "thin" "solid" ,(colorscheme-fg *colorscheme*)
242
+                      :color ,(colors:colorscheme-fg-deemph *colorscheme*)
243
+                      :border-bottom "thin" "solid" ,(colors:colorscheme-fg *colorscheme*)
294 244
                       ((:or a span)
295 245
                        :color inherit)
296 246
                       ((:and a :hover)
297
-                       :color ,(colorscheme-fg *colorscheme*))
247
+                       :color ,(colors:colorscheme-fg *colorscheme*))
298 248
                       ))
299 249
                  `((:and .feed-header :hover)
300
-                   :background-color ,(colorscheme-bg *colorscheme*))
301
-                 `(.link.closed
302
-                    (.link-header
303
-                      :background-color ,(colorscheme-bg *colorscheme*))
304
-                    ((:and .link-header :hover)
305
-                     :background-color ,(colorscheme-bg-highlight *colorscheme*)))
306
-
250
+                   :background-color ,(colors:colorscheme-hover-highlight *colorscheme*))
251
+                 `((.link.closed .link-header)
252
+                   :background-color ,(colors:colorscheme-bg *colorscheme*))
253
+
254
+                 `((:or (:and .link-header :hover) (.link.closed (:and .link-header)))
255
+                  :background-color ,(colors:colorscheme-hover-highlight *colorscheme*))
256
+                 `(blah
257
+                    :a ,(colors:colorscheme-fg-highlight *colorscheme*)
258
+                    :a ,(colors:colorscheme-hover-highlight *colorscheme*)
259
+                    :a ,(colors:colorscheme-bg-highlight *colorscheme*)
260
+                    )
307 261
                  )))
308
-      `(200 (:content-type "text/css") ,ss))))
262
+      `(200 (:content-type "text/css") ,ss)))))
309 263
 
310 264
 (defmacro item-markup (item)
311 265
   (alexandria:with-gensyms (item-s)
... ...
@@ -359,8 +313,8 @@
359 313
        (:link :rel "stylesheet" :href "/theme/light.css"))
360 314
      (:body
361 315
        (:header
362
-         (:button :class "flip-button" "c") 
363
-         (:h1 "Feeds")
316
+         (:button :class "flip-button" ">") 
317
+         (:h1 "What?")
364 318
          )
365 319
        (:section :id "content"
366 320
         (:section :id "sidebar"
... ...
@@ -399,10 +353,10 @@
399 353
 
400 354
 (cl-oid-connect:def-route ("/" (params) :app *app*)
401 355
   (ningle.context:with-context-variables (session)
402
-    (cl-oid-connect:require-login
403
-      (cl-oid-connect:require-login
356
+      ;(cl-oid-connect:require-login
404 357
         (let ((*feeds* (gethash :feeds session *feeds*)))
405
-          (base-template-f))))))
358
+          (base-template-f));)
359
+  ))
406 360
 
407 361
 (defvar *handler* nil)
408 362