alley-cat/alley-cat.scm

(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 irregex)
(use sxml-transforms srfi-69 scss srfi-13 lowdown doctype posix)

(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 ""))
(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)
  (set! *file-resources* (cons path *file-resources*)))

(define (delete-file-resource! path)
  (set! *file-resources* (remove (lambda (p) (equal? p path)) *file-resources*)))

(define (create-dirs path)
  (create-directory (pathname-directory path) #t))

(define (output-pages)
  (hash-table-for-each
   *pages*
   (lambda (k v)
     (let ((p (++ (out-dir) "/" k)))
       (create-dirs p)
       (with-output-to-file p
         (lambda () (print (doctype) (sxml->html v))))))))

(define (output-stylesheets)
  (hash-table-for-each
   *stylesheets*
   (lambda (k v)
     (let ((p (++ (out-dir) "/" k)))
       (create-dirs p)
       (with-output-to-file p
         (lambda () (scss->css v)))))))

(define (copy-file-resources)
  (for-each
   (lambda (p)
     (let ((path-out (++ (out-dir) "/" p)))
       (create-dirs path-out)
       (file-copy (++ (res-dir) "/" p) path-out)))
   *file-resources*))

(define (compile)
  (and (directory? (out-dir)) (delete-directory (out-dir) #t))
  (output-pages)
  (output-stylesheets)
  (copy-file-resources))

)