浏览代码

Push sketch slightly further up hill.

Brit Butler 11 年之前
父节点
当前提交
75c30c5844
共有 2 个文件被更改,包括 44 次插入12 次删除
  1. 34 5
      plugins/incremental.lisp
  2. 10 7
      src/util.lisp

+ 34 - 5
plugins/incremental.lisp

3
 
3
 
4
 (defpackage :coleslaw-incremental
4
 (defpackage :coleslaw-incremental
5
   (:use :cl)
5
   (:use :cl)
6
-  (:import-from :coleslaw #:get-updated-files
6
+  (:import-from :alexandria #:when-let)
7
+  (:import-from :coleslaw #:all-subclasses
8
+                          #:content
9
+                          #:construct
10
+                          #:get-updated-files
7
                           #:find-content-by-path
11
                           #:find-content-by-path
8
-                          #:write-document)
12
+                          #:write-document
13
+                          #:rel-path)
9
   (:export #:enable))
14
   (:export #:enable))
10
 
15
 
11
 (in-package :coleslaw-incremental)
16
 (in-package :coleslaw-incremental)
12
 
17
 
13
 ;; FIXME: We currently never update the site for config changes.
18
 ;; FIXME: We currently never update the site for config changes.
14
 ;; Examples to consider include changing the theme or domain of the site.
19
 ;; Examples to consider include changing the theme or domain of the site.
20
+;; Both would require full site recompiles. Consequently, it seems reasonable
21
+;; to expect that incremental plugin users:
22
+;;   A) have done a full build of their site
23
+;;   B) have a cl-store dump of the database at ~/.coleslaw.db
24
+;;      ^ we should provide a script or plugin just for this
15
 
25
 
16
 ;; NOTE: We're gonna be a bit dirty here and monkey patch. The compilation model
26
 ;; NOTE: We're gonna be a bit dirty here and monkey patch. The compilation model
17
 ;; still isn't an "exposed" part of Coleslaw. After some experimentation maybe
27
 ;; still isn't an "exposed" part of Coleslaw. After some experimentation maybe
21
   "A list of changed content instances to iterate over and write out to disk.")
31
   "A list of changed content instances to iterate over and write out to disk.")
22
 
32
 
23
 (defun coleslaw::load-content ()
33
 (defun coleslaw::load-content ()
24
-  ;; TODO: What if the file doesn't exist?
25
   (let ((db-file (rel-path (user-homedir-pathname) ".coleslaw.db")))
34
   (let ((db-file (rel-path (user-homedir-pathname) ".coleslaw.db")))
26
     (setf coleslaw::*site* (cl-store:restore db-file))
35
     (setf coleslaw::*site* (cl-store:restore db-file))
27
     (loop for (status path) in (get-updated-files)
36
     (loop for (status path) in (get-updated-files)
33
         ((string= "M" status) (process-change :modified path))
42
         ((string= "M" status) (process-change :modified path))
34
         ((string= "A" status) (process-change :added path))))
43
         ((string= "A" status) (process-change :added path))))
35
 
44
 
36
-(defgeneric process-change (status path)
37
-  (:documentation "Updates the database as needed for the STATUS change to PATH."))
45
+(defgeneric process-change (status path &key &allow-other-keys)
46
+  (:documentation "Updates the database as needed for the STATUS change to PATH.")
47
+  (:method :around (status path &key)
48
+    (let ((extension (pathname-type path))
49
+          (ctypes (all-subclasses (find-class 'content))))
50
+      ;; This feels way too clever. I wish I could think of a better option.
51
+      (flet ((class-name-p (x class)
52
+               (string-equal x (symbol-name (class-name class)))))
53
+        (when-let (ctype (find extension ctypes :test #'class-name-p))
54
+          (call-next-method status path :ctype ctype))))))
55
+
56
+(defmethod process-change ((status (eql :deleted)) path &key)
57
+  (let ((obj (find-content-by-path path)))
58
+    ))
59
+
60
+(defmethod process-change ((status (eql :modified)) path &key)
61
+  (let ((obj (find-content-by-path path)))
62
+    ))
63
+
64
+(defmethod process-change ((status (eql :added)) path &key ctype)
65
+  (let ((obj (construct ctype (read-content path))))
66
+    ))
38
 
67
 
39
 (defun coleslaw::compile-blog (staging)
68
 (defun coleslaw::compile-blog (staging)
40
   "lulz. Do it live. DO IT ALL LIVE."
69
   "lulz. Do it live. DO IT ALL LIVE."

+ 10 - 7
src/util.lisp

4
   "Create an instance of CLASS-NAME with the given ARGS."
4
   "Create an instance of CLASS-NAME with the given ARGS."
5
   (apply 'make-instance class-name args))
5
   (apply 'make-instance class-name args))
6
 
6
 
7
+;; Thanks to bknr-web for this bit of code.
8
+(defun all-subclasses (class)
9
+  "Return a list of all the subclasses of CLASS."
10
+  (let ((subclasses (closer-mop:class-direct-subclasses class)))
11
+    (append subclasses (loop for subclass in subclasses
12
+                          nconc (all-subclasses subclass)))))
13
+
7
 (defmacro do-subclasses ((var class) &body body)
14
 (defmacro do-subclasses ((var class) &body body)
8
   "Iterate over the subclasses of CLASS performing BODY with VAR
15
   "Iterate over the subclasses of CLASS performing BODY with VAR
9
 lexically bound to the current subclass."
16
 lexically bound to the current subclass."
10
-  (alexandria:with-gensyms (klasses all-subclasses)
11
-    `(labels ((,all-subclasses (class)
12
-                (let ((subclasses (closer-mop:class-direct-subclasses class)))
13
-                  (append subclasses (loop for subclass in subclasses
14
-                                        nconc (,all-subclasses subclass))))))
15
-       (let ((,klasses (,all-subclasses (find-class ',class))))
16
-         (loop for ,var in ,klasses do ,@body)))))
17
+  (alexandria:with-gensyms (klasses)
18
+    `(let ((,klasses (all-subclasses (find-class ',class))))
19
+       (loop for ,var in ,klasses do ,@body))))
17
 
20
 
18
 (defmacro do-files ((var path &optional extension) &body body)
21
 (defmacro do-files ((var path &optional extension) &body body)
19
   "For each file under PATH, run BODY. If EXTENSION is provided, only run
22
   "For each file under PATH, run BODY. If EXTENSION is provided, only run