Преглед изворни кода

Generalize DISCOVER for all content-types.

Brit Butler пре 12 година
родитељ
комит
58fe27aa54
3 измењених фајлова са 13 додато и 15 уклоњено
  1. 1 1
      src/coleslaw.lisp
  2. 12 5
      src/content.lisp
  3. 0 9
      src/posts.lisp

+ 1 - 1
src/coleslaw.lisp

@@ -54,7 +54,7 @@ Additional args to render CONTENT can be passed via RENDER-ARGS."
54 54
                        (merge-pathnames "static" (repo *config*))))
55 55
       (when (probe-file dir)
56 56
         (run-program "cp -R ~a ." dir)))
57
-    (do-ctypes (publish ctype))
57
+    (do-ctypes (publish (make-keyword ctype)))
58 58
     (render-indices)
59 59
     (render-feeds (feeds *config*))))
60 60
 

+ 12 - 5
src/content.lisp

@@ -34,9 +34,6 @@
34 34
   "Test if OBJ was written in MONTH."
35 35
   (search month (content-date obj)))
36 36
 
37
-(defgeneric discover (content-type)
38
-  (:documentation "Load all content of the given CONTENT-TYPE from disk."))
39
-
40 37
 (defgeneric publish (content-type)
41 38
   (:documentation "Write pages to disk for all content of the given CONTENT-TYPE."))
42 39
 
@@ -74,13 +71,23 @@
74 71
   (dolist (obj (find-all content-type))
75 72
     (remhash (content-slug obj) *content*)))
76 73
 
74
+(defun discover (content-type)
75
+  "Load all content of the given CONTENT-TYPE from disk."
76
+  (purge-all content-type)
77
+  (let ((file-type (string-downcase (princ-to-string content-type))))
78
+    (do-files (file (repo *config*) file-type)
79
+      (let ((obj (construct content-type (read-content file))))
80
+        (if (gethash (content-slug obj) *content*)
81
+            (error "There is already existing content with the slug ~a."
82
+                   (content-slug obj))
83
+            (setf (gethash (content-slug obj) *content*) obj))))))
84
+
77 85
 (defmacro do-ctypes (&body body)
78 86
   "Iterate over the subclasses of CONTENT performing BODY with ctype lexically
79 87
 bound to the current subclass."
80 88
   (alexandria:with-gensyms (ctypes)
81 89
     `(let ((,ctypes (closer-mop:class-direct-subclasses (find-class 'content))))
82
-       (loop for ctype in (mapcar (compose 'make-keyword 'class-name) ,ctypes)
83
-          do ,@body))))
90
+       (loop for ctype in (mapcar #'class-name ,ctypes) do ,@body))))
84 91
 
85 92
 (defun load-content ()
86 93
   "Load all content stored in the blog's repo."

+ 0 - 9
src/posts.lisp

@@ -21,15 +21,6 @@
21 21
             format (make-keyword (string-upcase format))
22 22
             text (render-content text format))))
23 23
 
24
-(defmethod discover ((content-type (eql :post)))
25
-  (purge-all 'post)
26
-  (do-files (file (repo *config*) "post")
27
-    (let ((post (construct 'post (read-content file))))
28
-      (if (gethash (content-slug post) *content*)
29
-          (error "There is already an existing post with the slug ~a."
30
-                 (content-slug post))
31
-          (setf (gethash (content-slug post) *content*) post)))))
32
-
33 24
 (defmethod publish ((content-type (eql :post)))
34 25
   (loop for (next post prev) on (append '(nil) (by-date (find-all 'post)))
35 26
      while post do (write-page (page-path post)