Initial commit.

alley-cat.scm

@@ -0,0 +1,108 @@
+(module alley-cat
+  (
+   ; params
+   src-dir out-dir res-dir link-root doctype
+
+   ; generic functions
+   sxml->html
+
+   ; helper functions
+   markdown-file->sxml link link-list css
+
+   ; core functions
+   add-page! delete-page! add-css! delete-css!
+   add-file-resource! delete-file-resource!
+   compile
+  )
+
+(import chicken scheme files srfi-1 extras ports)
+(use sxml-transforms srfi-69 scss srfi-13 lowdown doctype)
+
+(define *pages* (make-hash-table))
+(define *stylesheets* (make-hash-table))
+(define *file-resources* '())
+
+(define src-dir (make-parameter "src"))
+(define out-dir (make-parameter "out"))
+(define res-dir (make-parameter "res"))
+(define link-root (make-parameter "/home"))
+(define doctype (make-parameter doctype-html))
+
+(define ++ string-append)
+
+(define (map-match func list)
+  (if (null? list)
+      '()
+      (cons (apply func (car list))
+            (map-match func (cdr list)))))
+
+; take from awful: Copyright (c) 2010-2013, Mario Domenech Goulart; BSD
+(define sxml->html
+  (let ((rules `((literal *preorder* . ,(lambda (t b) b))
+                 . ,universal-conversion-rules*)))
+    (lambda (sxml)
+      (with-output-to-string
+        (lambda ()
+          (SRV:send-reply (pre-post-order* sxml rules)))))))
+
+(define (link path text)
+  `(a (@ (href ,(if (and (> (string-length path) 0)
+                         (string=? "/" (string-take path 1)))
+                    (++ (link-root) path)
+                    path))) ,text))
+
+(define (link-list list #!key (ul@ '(@ ())) (li@ '(@ ())))
+  `(ul ,ul@
+       ,(map-match (lambda (path text)
+                     `(li ,li@ ,(link path text)))
+                   list)))
+
+(define (markdown-file->sxml file-path)
+  (markdown->sxml (with-input-from-file file-path (lambda () (read-string)))))
+
+(define (css path)
+  `(link (@ (rel "stylesheet") (href ,(++ (link-root) path)))))
+
+(define (add-page! path body)
+  (hash-table-set! *pages* path body))
+
+(define (delete-page! path)
+  (hash-table-delete! *pages* path))
+
+(define (add-css! path body)
+  (hash-table-set! *stylesheets* path body))
+
+(define (delete-css! path)
+  (hash-table-delete! *stylesheets* path))
+
+(define (add-file-resource! path)
+  (cons path *file-resources*))
+
+(define (delete-file-resource! path)
+  (remove (lambda (p) (equal? p path)) *file-resources*))
+
+(define (output-pages)
+  (hash-table-for-each
+   *pages*
+   (lambda (k v)
+     (with-output-to-file (++ (out-dir) "/" k)
+       (lambda () (print (doctype) (sxml->html v)))))))
+
+(define (output-stylesheets)
+  (hash-table-for-each
+   *stylesheets*
+   (lambda (k v)
+     (with-output-to-file (++ (out-dir) "/" k)
+       (lambda () (scss->css v))))))
+
+(define (copy-file-resources)
+  (for-each (lambda (p)
+              (file-copy (++ (res-dir) "/" p) (++ (out-dir) "/" p)))
+            *file-resources*))
+
+(define (compile)
+  (output-pages)
+  (output-stylesheets)
+  (copy-file-resources))
+
+)