You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

123 lines
3.3 KiB

(module alley-cat
; params
src-dir out-dir res-dir link-root doctype
; generic functions
; helper functions
markdown-file->sxml link link-list css js
; core functions
add-page! delete-page! add-css! delete-css!
add-file-resource! delete-file-resource!
(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)
(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)))
(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 (js path)
`(script (@ (type "text/javascript") (src ,(++ (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)
(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)
(lambda (k v)
(let ((p (++ (out-dir) "/" k)))
(create-dirs p)
(with-output-to-file p
(lambda () (scss->css v)))))))
(define (copy-file-resources)
(lambda (p)
(let ((path-out (++ (out-dir) "/" p)))
(create-dirs path-out)
(file-copy (++ (res-dir) "/" p) path-out)))
(define (compile-site #!key (clean #t))
(when clean (and (directory? (out-dir)) (delete-directory (out-dir) #t)))